home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / controls.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  170.6 KB  |  6,139 lines
  1. // TODO:
  2. //   - Find a home for TStreamAdapter
  3.  
  4. {*******************************************************}
  5. {                                                       }
  6. {       Delphi Visual Component Library                 }
  7. {                                                       }
  8. {       Copyright (c) 1995,97 Borland International     }
  9. {                                                       }
  10. {*******************************************************}
  11.  
  12. unit Controls;
  13.  
  14. {$P+,S-,W-,R-}
  15. {$C PRELOAD}
  16.  
  17. interface
  18.  
  19. {$R CONTROLS}
  20.  
  21. uses Messages, Windows, Classes, Sysutils, Graphics, Menus, CommCtrl, Imm;
  22.  
  23. { VCL control message IDs }
  24.  
  25. const
  26.   CM_BASE                   = $B000;
  27.   CM_ACTIVATE               = CM_BASE + 0;
  28.   CM_DEACTIVATE             = CM_BASE + 1;
  29.   CM_GOTFOCUS               = CM_BASE + 2;
  30.   CM_LOSTFOCUS              = CM_BASE + 3;
  31.   CM_CANCELMODE             = CM_BASE + 4;
  32.   CM_DIALOGKEY              = CM_BASE + 5;
  33.   CM_DIALOGCHAR             = CM_BASE + 6;
  34.   CM_FOCUSCHANGED           = CM_BASE + 7;
  35.   CM_PARENTFONTCHANGED      = CM_BASE + 8;
  36.   CM_PARENTCOLORCHANGED     = CM_BASE + 9;
  37.   CM_HITTEST                = CM_BASE + 10;
  38.   CM_VISIBLECHANGED         = CM_BASE + 11;
  39.   CM_ENABLEDCHANGED         = CM_BASE + 12;
  40.   CM_COLORCHANGED           = CM_BASE + 13;
  41.   CM_FONTCHANGED            = CM_BASE + 14;
  42.   CM_CURSORCHANGED          = CM_BASE + 15;
  43.   CM_CTL3DCHANGED           = CM_BASE + 16;
  44.   CM_PARENTCTL3DCHANGED     = CM_BASE + 17;
  45.   CM_TEXTCHANGED            = CM_BASE + 18;
  46.   CM_MOUSEENTER             = CM_BASE + 19;
  47.   CM_MOUSELEAVE             = CM_BASE + 20;
  48.   CM_MENUCHANGED            = CM_BASE + 21;
  49.   CM_APPKEYDOWN             = CM_BASE + 22;
  50.   CM_APPSYSCOMMAND          = CM_BASE + 23;
  51.   CM_BUTTONPRESSED          = CM_BASE + 24;
  52.   CM_SHOWINGCHANGED         = CM_BASE + 25;
  53.   CM_ENTER                  = CM_BASE + 26;
  54.   CM_EXIT                   = CM_BASE + 27;
  55.   CM_DESIGNHITTEST          = CM_BASE + 28;
  56.   CM_ICONCHANGED            = CM_BASE + 29;
  57.   CM_WANTSPECIALKEY         = CM_BASE + 30;
  58.   CM_INVOKEHELP             = CM_BASE + 31;
  59.   CM_WINDOWHOOK             = CM_BASE + 32;
  60.   CM_RELEASE                = CM_BASE + 33;
  61.   CM_SHOWHINTCHANGED        = CM_BASE + 34;
  62.   CM_PARENTSHOWHINTCHANGED  = CM_BASE + 35;
  63.   CM_SYSCOLORCHANGE         = CM_BASE + 36;
  64.   CM_WININICHANGE           = CM_BASE + 37;
  65.   CM_FONTCHANGE             = CM_BASE + 38;
  66.   CM_TIMECHANGE             = CM_BASE + 39;
  67.   CM_TABSTOPCHANGED         = CM_BASE + 40;
  68.   CM_UIACTIVATE             = CM_BASE + 41;
  69.   CM_UIDEACTIVATE           = CM_BASE + 42;
  70.   CM_DOCWINDOWACTIVATE      = CM_BASE + 43;
  71.   CM_CONTROLLISTCHANGE      = CM_BASE + 44;
  72.   CM_GETDATALINK            = CM_BASE + 45;
  73.   CM_CHILDKEY               = CM_BASE + 46;
  74.   CM_DRAG                   = CM_BASE + 47;
  75.   CM_HINTSHOW               = CM_BASE + 48;
  76.   CM_DIALOGHANDLE           = CM_BASE + 49;
  77.   CM_ISTOOLCONTROL          = CM_BASE + 50;
  78.   CM_RECREATEWND            = CM_BASE + 51;
  79.   CM_INVALIDATE             = CM_BASE + 52;
  80.   CM_SYSFONTCHANGED         = CM_BASE + 53;
  81.   CM_CONTROLCHANGE          = CM_BASE + 54;
  82.   CM_CHANGED                = CM_BASE + 55;
  83.  
  84. { VCL control notification IDs }
  85.  
  86. const
  87.   CN_BASE              = $BC00;
  88.   CN_CHARTOITEM        = CN_BASE + WM_CHARTOITEM;
  89.   CN_COMMAND           = CN_BASE + WM_COMMAND;
  90.   CN_COMPAREITEM       = CN_BASE + WM_COMPAREITEM;
  91.   CN_CTLCOLORBTN       = CN_BASE + WM_CTLCOLORBTN;
  92.   CN_CTLCOLORDLG       = CN_BASE + WM_CTLCOLORDLG;
  93.   CN_CTLCOLOREDIT      = CN_BASE + WM_CTLCOLOREDIT;
  94.   CN_CTLCOLORLISTBOX   = CN_BASE + WM_CTLCOLORLISTBOX;
  95.   CN_CTLCOLORMSGBOX    = CN_BASE + WM_CTLCOLORMSGBOX;
  96.   CN_CTLCOLORSCROLLBAR = CN_BASE + WM_CTLCOLORSCROLLBAR;
  97.   CN_CTLCOLORSTATIC    = CN_BASE + WM_CTLCOLORSTATIC;
  98.   CN_DELETEITEM        = CN_BASE + WM_DELETEITEM;
  99.   CN_DRAWITEM          = CN_BASE + WM_DRAWITEM;
  100.   CN_HSCROLL           = CN_BASE + WM_HSCROLL;
  101.   CN_MEASUREITEM       = CN_BASE + WM_MEASUREITEM;
  102.   CN_PARENTNOTIFY      = CN_BASE + WM_PARENTNOTIFY;
  103.   CN_VKEYTOITEM        = CN_BASE + WM_VKEYTOITEM;
  104.   CN_VSCROLL           = CN_BASE + WM_VSCROLL;
  105.   CN_KEYDOWN           = CN_BASE + WM_KEYDOWN;
  106.   CN_KEYUP             = CN_BASE + WM_KEYUP;
  107.   CN_CHAR              = CN_BASE + WM_CHAR;
  108.   CN_SYSKEYDOWN        = CN_BASE + WM_SYSKEYDOWN;
  109.   CN_SYSCHAR           = CN_BASE + WM_SYSCHAR;
  110.   CN_NOTIFY            = CN_BASE + WM_NOTIFY;
  111.  
  112. { TModalResult values }
  113.  
  114. const
  115.   mrNone     = 0;
  116.   mrOk       = idOk;
  117.   mrCancel   = idCancel;
  118.   mrAbort    = idAbort;
  119.   mrRetry    = idRetry;
  120.   mrIgnore   = idIgnore;
  121.   mrYes      = idYes;
  122.   mrNo       = idNo;
  123.   mrAll      = mrNo + 1;
  124.   mrNoToAll  = mrAll + 1;
  125.   mrYesToAll = mrNoToAll + 1;
  126.  
  127. { Cursor identifiers }
  128.  
  129. const
  130.   crDefault     = 0;
  131.   crNone        = -1;
  132.   crArrow       = -2;
  133.   crCross       = -3;
  134.   crIBeam       = -4;
  135.   crSize        = -5;
  136.   crSizeNESW    = -6;
  137.   crSizeNS      = -7;
  138.   crSizeNWSE    = -8;
  139.   crSizeWE      = -9;
  140.   crUpArrow     = -10;
  141.   crHourGlass   = -11;
  142.   crDrag        = -12;
  143.   crNoDrop      = -13;
  144.   crHSplit      = -14;
  145.   crVSplit      = -15;
  146.   crMultiDrag   = -16;
  147.   crSQLWait     = -17;
  148.   crNo          = -18;
  149.   crAppStart    = -19;
  150.   crHelp        = -20;
  151.  
  152. type
  153.  
  154. { Forward declarations }
  155.  
  156.   TDragObject = class;
  157.   TControl = class;
  158.   TWinControl = class;
  159.   TCustomImageList = class;
  160.  
  161. { VCL control message records }
  162.  
  163.   TCMActivate = TWMNoParams;
  164.   TCMDeactivate = TWMNoParams;
  165.   TCMGotFocus = TWMNoParams;
  166.   TCMLostFocus = TWMNoParams;
  167.   TCMDialogKey = TWMKey;
  168.   TCMDialogChar = TWMKey;
  169.   TCMHitTest = TWMNCHitTest;
  170.   TCMEnter = TWMNoParams;
  171.   TCMExit = TWMNoParams;
  172.   TCMDesignHitTest = TWMMouse;
  173.   TCMWantSpecialKey = TWMKey;
  174.  
  175.   TCMCancelMode = record
  176.     Msg: Cardinal;
  177.     Unused: Integer;
  178.     Sender: TControl;
  179.     Result: Longint;
  180.   end;
  181.  
  182.   TCMFocusChanged = record
  183.     Msg: Cardinal;
  184.     Unused: Integer;
  185.     Sender: TWinControl;
  186.     Result: Longint;
  187.   end;
  188.  
  189.   TCMControlListChange = record
  190.     Msg: Cardinal;
  191.     Control: TControl;
  192.     Inserting: LongBool;
  193.     Result: Longint;
  194.   end;
  195.  
  196.   TCMChildKey = record
  197.     Msg: Cardinal;
  198.     CharCode: Word;
  199.     Unused: Word;
  200.     Sender: TWinControl;
  201.     Result: Longint;
  202.   end;
  203.  
  204.   TCMControlChange = record
  205.     Msg: Cardinal;
  206.     Control: TControl;
  207.     Inserting: LongBool;
  208.     Result: Longint;
  209.   end;
  210.  
  211.   TCMChanged = record
  212.     Msg: Cardinal;
  213.     Unused: Longint;
  214.     Child: TControl;
  215.     Result: Longint;
  216.   end;
  217.  
  218.   TDragMessage = (dmDragEnter, dmDragLeave, dmDragMove, dmDragDrop, dmDragCancel,
  219.     dmFindTarget);
  220.  
  221.   PDragRec = ^TDragRec;
  222.   TDragRec = record
  223.     Pos: TPoint;
  224.     Source: TDragObject;
  225.     Target: Pointer;
  226.   end;
  227.  
  228.   TCMDrag = packed record
  229.     Msg: Cardinal;
  230.     DragMessage: TDragMessage;
  231.     Reserved1: Byte;
  232.     Reserved2: Word;
  233.     DragRec: PDragRec;
  234.     Result: Longint;
  235.   end;
  236.  
  237. { Cursor type }
  238.  
  239.   TCursor = -32768..32767;
  240.  
  241. { Dragging objects }
  242.  
  243.   TDragObject = class(TObject)
  244.   private
  245.     procedure MouseMsg(var Msg: TMessage);
  246.     function Capture: HWND;
  247.     procedure ReleaseCapture(Handle: HWND);
  248.   protected
  249.     function GetDragImages: TCustomImageList; virtual;
  250.     function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; virtual;
  251.     procedure Finished(Target: TObject; X, Y: Integer; Accepted: Boolean); virtual;
  252.   public
  253.     function Instance: THandle; virtual;
  254.     function GetName: string; virtual;
  255.     procedure HideDragImage; virtual;
  256.     procedure ShowDragImage; virtual;
  257.   end;
  258.  
  259.   TDragControlObject = class(TDragObject)
  260.   private
  261.     FControl: TControl;
  262.   protected
  263.     function GetDragImages: TCustomImageList; override;
  264.     function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
  265.     procedure Finished(Target: TObject; X, Y: Integer; Accepted: Boolean); override;
  266.   public
  267.     constructor Create(AControl: TControl);
  268.     property Control: TControl read FControl;
  269.     procedure HideDragImage; override;
  270.     procedure ShowDragImage; override;
  271.   end;
  272.  
  273. { Controls }
  274.  
  275.   TControlCanvas = class(TCanvas)
  276.   private
  277.     FControl: TControl;
  278.     FDeviceContext: HDC;
  279.     FWindowHandle: HWnd;
  280.     procedure SetControl(AControl: TControl);
  281.   protected
  282.     procedure CreateHandle; override;
  283.   public
  284.     destructor Destroy; override;
  285.     procedure FreeHandle;
  286.     property Control: TControl read FControl write SetControl;
  287.   end;
  288.  
  289.   TAlign = (alNone, alTop, alBottom, alLeft, alRight, alClient);
  290.  
  291.   TControlState = set of (csLButtonDown, csClicked, csPalette,
  292.     csReadingState, csAlignmentNeeded, csFocusing, csCreating,
  293.     csPaintCopy);
  294.  
  295.   TControlStyle = set of (csAcceptsControls, csCaptureMouse,
  296.     csDesignInteractive, csClickEvents, csFramed, csSetCaption, csOpaque,
  297.     csDoubleClicks, csFixedWidth, csFixedHeight, csNoDesignVisible,
  298.     csReplicatable, csNoStdEvents, csDisplayDragImage);
  299.  
  300.   TMouseButton = (mbLeft, mbRight, mbMiddle);
  301.  
  302.   TDragMode = (dmManual, dmAutomatic);
  303.  
  304.   TDragState = (dsDragEnter, dsDragLeave, dsDragMove);
  305.  
  306.   TTabOrder = -1..32767;
  307.  
  308.   TCaption = type string;
  309.  
  310.   TDate = type TDateTime;
  311.  
  312.   TTime = type TDateTime;
  313.  
  314.   TScalingFlags = set of (sfLeft, sfTop, sfWidth, sfHeight, sfFont);
  315.  
  316.   TMouseEvent = procedure(Sender: TObject; Button: TMouseButton;
  317.     Shift: TShiftState; X, Y: Integer) of object;
  318.   TMouseMoveEvent = procedure(Sender: TObject; Shift: TShiftState;
  319.     X, Y: Integer) of object;
  320.   TKeyEvent = procedure(Sender: TObject; var Key: Word;
  321.     Shift: TShiftState) of object;
  322.   TKeyPressEvent = procedure(Sender: TObject; var Key: Char) of object;
  323.   TDragOverEvent = procedure(Sender, Source: TObject; X, Y: Integer;
  324.     State: TDragState; var Accept: Boolean) of object;
  325.   TDragDropEvent = procedure(Sender, Source: TObject;
  326.     X, Y: Integer) of object;
  327.   TStartDragEvent = procedure(Sender: TObject;
  328.     var DragObject: TDragObject) of object;
  329.   TEndDragEvent = procedure(Sender, Target: TObject;
  330.     X, Y: Integer) of object;
  331.  
  332.   TWndMethod = procedure(var Message: TMessage) of object;
  333.  
  334.   TControl = class(TComponent)
  335.   private
  336.     FParent: TWinControl;
  337.     FWindowProc: TWndMethod;
  338.     FLeft: Integer;
  339.     FTop: Integer;
  340.     FWidth: Integer;
  341.     FHeight: Integer;
  342.     FControlStyle: TControlStyle;
  343.     FControlState: TControlState;
  344.     FVisible: Boolean;
  345.     FEnabled: Boolean;
  346.     FParentFont: Boolean;
  347.     FParentColor: Boolean;
  348.     FAlign: TAlign;
  349.     FDragMode: TDragMode;
  350.     FIsControl: Boolean;
  351.     FText: PChar;
  352.     FFont: TFont;
  353.     FColor: TColor;
  354.     FCursor: TCursor;
  355.     FDragCursor: TCursor;
  356.     FPopupMenu: TPopupMenu;
  357.     FHint: string;
  358.     FFontHeight: Integer;
  359.     FScalingFlags: TScalingFlags;
  360.     FShowHint: Boolean;
  361.     FParentShowHint: Boolean;
  362.     FOnMouseDown: TMouseEvent;
  363.     FOnMouseMove: TMouseMoveEvent;
  364.     FOnMouseUp: TMouseEvent;
  365.     FOnDragDrop: TDragDropEvent;
  366.     FOnDragOver: TDragOverEvent;
  367.     FOnStartDrag: TStartDragEvent;
  368.     FOnEndDrag: TEndDragEvent;
  369.     FOnClick: TNotifyEvent;
  370.     FOnDblClick: TNotifyEvent;
  371.     procedure CheckMenuPopup(const Pos: TSmallPoint);
  372.     procedure DoDragMsg(var DragMsg: TCMDrag);
  373.     procedure DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
  374.       Shift: TShiftState);
  375.     procedure DoMouseUp(var Message: TWMMouse; Button: TMouseButton);
  376.     procedure FontChanged(Sender: TObject);
  377.     function GetBoundsRect: TRect;
  378.     function GetClientHeight: Integer;
  379.     function GetClientWidth: Integer;
  380.     function GetMouseCapture: Boolean;
  381.     function GetText: TCaption;
  382.     procedure InvalidateControl(IsVisible, IsOpaque: Boolean);
  383.     function IsColorStored: Boolean;
  384.     function IsFontStored: Boolean;
  385.     function IsShowHintStored: Boolean;
  386.     procedure ReadIsControl(Reader: TReader);
  387.     procedure RequestAlign;
  388.     procedure SetAlign(Value: TAlign);
  389.     procedure SetBoundsRect(const Rect: TRect);
  390.     procedure SetClientHeight(Value: Integer);
  391.     procedure SetClientSize(Value: TPoint);
  392.     procedure SetClientWidth(Value: Integer);
  393.     procedure SetColor(Value: TColor);
  394.     procedure SetCursor(Value: TCursor);
  395.     procedure SetEnabled(Value: Boolean);
  396.     procedure SetFont(Value: TFont);
  397.     procedure SetHeight(Value: Integer);
  398.     procedure SetLeft(Value: Integer);
  399.     procedure SetMouseCapture(Value: Boolean);
  400.     procedure SetParentColor(Value: Boolean);
  401.     procedure SetParentFont(Value: Boolean);
  402.     procedure SetShowHint(Value: Boolean);
  403.     procedure SetParentShowHint(Value: Boolean);
  404.     procedure SetPopupMenu(Value: TPopupMenu);
  405.     procedure SetText(const Value: TCaption);
  406.     procedure SetTop(Value: Integer);
  407.     procedure SetVisible(Value: Boolean);
  408.     procedure SetWidth(Value: Integer);
  409.     procedure SetZOrderPosition(Position: Integer);
  410.     procedure WriteIsControl(Writer: TWriter);
  411.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  412.     procedure WMNCLButtonDown(var Message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
  413.     procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
  414.     procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN;
  415.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  416.     procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;
  417.     procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;
  418.     procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
  419.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  420.     procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
  421.     procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP;
  422.     procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;
  423.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  424.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  425.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  426.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  427.     procedure CMParentFontChanged(var Message: TMessage); message CM_PARENTFONTCHANGED;
  428.     procedure CMSysFontChanged(var Message: TMessage); message CM_SYSFONTCHANGED;
  429.     procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
  430.     procedure CMParentShowHintChanged(var Message: TMessage); message CM_PARENTSHOWHINTCHANGED;
  431.     procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
  432.     procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  433.     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  434.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  435.   protected
  436.     procedure Changed;
  437.     procedure ChangeScale(M, D: Integer); dynamic;
  438.     procedure Click; dynamic;
  439.     procedure DblClick; dynamic;
  440.     procedure DefaultHandler(var Message); override;
  441.     procedure DefineProperties(Filer: TFiler); override;
  442.     procedure DragCanceled; dynamic;
  443.     procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
  444.       var Accept: Boolean); dynamic;
  445.     procedure DoEndDrag(Target: TObject; X, Y: Integer); dynamic;
  446.     procedure DoStartDrag(var DragObject: TDragObject); dynamic;
  447.     function GetClientOrigin: TPoint; virtual;
  448.     function GetClientRect: TRect; virtual;
  449.     function GetDeviceContext(var WindowHandle: HWnd): HDC; virtual;
  450.     function GetDragImages: TCustomImageList; virtual;
  451.     function GetPalette: HPALETTE; dynamic;
  452.     function GetParentComponent: TComponent; override;
  453.     function GetPopupMenu: TPopupMenu; dynamic;
  454.     function HasParent: Boolean; override;
  455.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  456.       X, Y: Integer); dynamic;
  457.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); dynamic;
  458.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  459.       X, Y: Integer); dynamic;
  460.     procedure Notification(AComponent: TComponent;
  461.       Operation: TOperation); override;
  462.     function PaletteChanged(Foreground: Boolean): Boolean; dynamic;
  463.     procedure ReadState(Reader: TReader); override;
  464.     procedure SendCancelMode(Sender: TControl);
  465.     procedure SetDragMode(Value: TDragMode); virtual;
  466.     procedure SetParent(AParent: TWinControl); virtual;
  467.     procedure SetParentComponent(Value: TComponent); override;
  468.     procedure SetName(const Value: TComponentName); override;
  469.     procedure SetZOrder(TopMost: Boolean); dynamic;
  470.     procedure UpdateBoundsRect(const R: TRect);
  471.     procedure VisibleChanging; dynamic;
  472.     procedure WndProc(var Message: TMessage); virtual;
  473.     property Caption: TCaption read GetText write SetText;
  474.     property Color: TColor read FColor write SetColor stored IsColorStored default clWindow;
  475.     property DragCursor: TCursor read FDragCursor write FDragCursor default crDrag;
  476.     property DragMode: TDragMode read FDragMode write SetDragMode default dmManual;
  477.     property Font: TFont read FFont write SetFont stored IsFontStored;
  478.     property IsControl: Boolean read FIsControl write FIsControl;
  479.     property MouseCapture: Boolean read GetMouseCapture write SetMouseCapture;
  480.     property ParentColor: Boolean read FParentColor write SetParentColor default True;
  481.     property ParentFont: Boolean read FParentFont write SetParentFont default True;
  482.     property ParentShowHint: Boolean read FParentShowHint write SetParentShowHint default True;
  483.     property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
  484.     property ScalingFlags: TScalingFlags read FScalingFlags write FScalingFlags;
  485.     property Text: TCaption read GetText write SetText;
  486.     property WindowText: PChar read FText write FText;
  487.     property OnClick: TNotifyEvent read FOnClick write FOnClick;
  488.     property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
  489.     property OnDragDrop: TDragDropEvent read FOnDragDrop write FOnDragDrop;
  490.     property OnDragOver: TDragOverEvent read FOnDragOver write FOnDragOver;
  491.     property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag;
  492.     property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
  493.     property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
  494.     property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
  495.     property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag;
  496.   public
  497.     constructor Create(AOwner: TComponent); override;
  498.     destructor Destroy; override;
  499.     procedure BeginDrag(Immediate: Boolean);
  500.     procedure BringToFront;
  501.     function ClientToScreen(const Point: TPoint): TPoint;
  502.     function Dragging: Boolean;
  503.     procedure DragDrop(Source: TObject; X, Y: Integer); dynamic;
  504.     procedure EndDrag(Drop: Boolean);
  505.     function GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  506.     function GetTextLen: Integer;
  507.     procedure Hide;
  508.     procedure Invalidate; virtual;
  509.     function Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;
  510.     procedure Refresh;
  511.     procedure Repaint; virtual;
  512.     function ScreenToClient(const Point: TPoint): TPoint;
  513.     procedure SendToBack;
  514.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual;
  515.     procedure SetTextBuf(Buffer: PChar);
  516.     procedure Show;
  517.     procedure Update; virtual;
  518.     property Align: TAlign read FAlign write SetAlign default alNone;
  519.     property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
  520.     property ClientHeight: Integer read GetClientHeight write SetClientHeight stored False;
  521.     property ClientOrigin: TPoint read GetClientOrigin;
  522.     property ClientRect: TRect read GetClientRect;
  523.     property ClientWidth: Integer read GetClientWidth write SetClientWidth stored False;
  524.     property ControlState: TControlState read FControlState write FControlState;
  525.     property ControlStyle: TControlStyle read FControlStyle write FControlStyle;
  526.     property Parent: TWinControl read FParent write SetParent;
  527.     property ShowHint: Boolean read FShowHint write SetShowHint stored IsShowHintStored;
  528.     property Visible: Boolean read FVisible write SetVisible default True;
  529.     property Enabled: Boolean read FEnabled write SetEnabled default True;
  530.     property WindowProc: TWndMethod read FWindowProc write FWindowProc;
  531.   published
  532.     property Left: Integer read FLeft write SetLeft;
  533.     property Top: Integer read FTop write SetTop;
  534.     property Width: Integer read FWidth write SetWidth;
  535.     property Height: Integer read FHeight write SetHeight;
  536.     property Cursor: TCursor read FCursor write SetCursor default crDefault;
  537.     property Hint: string read FHint write FHint;
  538.   end;
  539.  
  540.   TControlClass = class of TControl;
  541.  
  542.   TCreateParams = record
  543.     Caption: PChar;
  544.     Style: Longint;
  545.     ExStyle: Longint;
  546.     X, Y: Integer;
  547.     Width, Height: Integer;
  548.     WndParent: HWnd;
  549.     Param: Pointer;
  550.     WindowClass: TWndClass;
  551.     WinClassName: array[0..63] of Char;
  552.   end;
  553.  
  554.   TImeMode = (imDisable, imClose, imOpen, imDontCare,
  555.               imSAlpha, imAlpha, imHira, imSKata, imKata,
  556.               imChinese, imSHanguel, imHanguel);
  557.   TImeName = type string;
  558.  
  559.   TWinControl = class(TControl)
  560.   private
  561.     FObjectInstance: Pointer;
  562.     FDefWndProc: Pointer;
  563.     FControls: TList;
  564.     FWinControls: TList;
  565.     FTabList: TList;
  566.     FBrush: TBrush;
  567.     FHandle: HWnd;
  568.     FParentWindow: HWnd;
  569.     FTabStop: Boolean;
  570.     FCtl3D: Boolean;
  571.     FParentCtl3D: Boolean;
  572.     FShowing: Boolean;
  573.     FTabOrder: Integer;
  574.     FAlignLevel: Word;
  575.     FHelpContext: THelpContext;
  576.     FImeMode: TImeMode;
  577.     FImeName: TImeName;
  578.     FOnKeyDown: TKeyEvent;
  579.     FOnKeyPress: TKeyPressEvent;
  580.     FOnKeyUp: TKeyEvent;
  581.     FOnEnter: TNotifyEvent;
  582.     FOnExit: TNotifyEvent;
  583.     procedure AlignControl(AControl: TControl);
  584.     function GetControl(Index: Integer): TControl;
  585.     function GetControlCount: Integer;
  586.     function GetHandle: HWnd;
  587.     function GetTabOrder: TTabOrder;
  588.     procedure Insert(AControl: TControl);
  589.     procedure InvalidateFrame;
  590.     function IsCtl3DStored: Boolean;
  591.     function PrecedingWindow(Control: TWinControl): HWnd;
  592.     procedure Remove(AControl: TControl);
  593.     procedure RemoveFocus(Removing: Boolean);
  594.     procedure SetCtl3D(Value: Boolean);
  595.     procedure SetParentCtl3D(Value: Boolean);
  596.     procedure SetParentWindow(Value: HWnd);
  597.     procedure SetTabOrder(Value: TTabOrder);
  598.     procedure SetTabStop(Value: Boolean);
  599.     procedure SetZOrderPosition(Position: Integer);
  600.     procedure UpdateTabOrder(Value: TTabOrder);
  601.     procedure UpdateBounds;
  602.     procedure UpdateShowing;
  603.     function IsMenuKey(var Message: TWMKey): Boolean;
  604.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  605.     procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
  606.     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  607.     procedure WMSysColorChange(var Message: TWMSysColorChange); message WM_SYSCOLORCHANGE;
  608.     procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
  609.     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  610.     procedure WMCompareItem(var Message: TWMCompareItem); message WM_COMPAREITEM;
  611.     procedure WMDeleteItem(var Message: TWMDeleteItem); message WM_DELETEITEM;
  612.     procedure WMDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM;
  613.     procedure WMMeasureItem(var Message: TWMMeasureItem); message WM_MEASUREITEM;
  614.     procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
  615.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  616.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  617.     procedure WMMove(var Message: TWMMove); message WM_MOVE;
  618.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  619.     procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
  620.     procedure WMSysKeyDown(var Message: TWMKeyDown); message WM_SYSKEYDOWN;
  621.     procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
  622.     procedure WMSysKeyUp(var Message: TWMKeyUp); message WM_SYSKEYUP;
  623.     procedure WMChar(var Message: TWMChar); message WM_CHAR;
  624.     procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
  625.     procedure WMCharToItem(var Message: TWMCharToItem); message WM_CHARTOITEM;
  626.     procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
  627.     procedure WMVKeyToItem(var Message: TWMVKeyToItem); message WM_VKEYTOITEM;
  628.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  629.     procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
  630.     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  631.     procedure WMQueryNewPalette(var Message: TMessage); message WM_QUERYNEWPALETTE;
  632.     procedure WMPaletteChanged(var Message: TMessage); message WM_PALETTECHANGED;
  633.     procedure WMWinIniChange(var Message: TMessage); message WM_WININICHANGE;
  634.     procedure WMFontChange(var Message: TMessage); message WM_FONTCHANGE;
  635.     procedure WMTimeChange(var Message: TMessage); message WM_TIMECHANGE;
  636.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  637.     procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
  638.     procedure WMIMEStartComp(var Message: TMessage); message WM_IME_STARTCOMPOSITION;
  639.     procedure WMIMEEndComp(var Message: TMessage); message WM_IME_ENDCOMPOSITION;
  640.     procedure CMChanged(var Message: TMessage); message CM_CHANGED;
  641.     procedure CMChildKey(var Message: TMessage); message CM_CHILDKEY;
  642.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  643.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  644.     procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
  645.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  646.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  647.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  648.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  649.     procedure CMCursorChanged(var Message: TMessage); message CM_CURSORCHANGED;
  650.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  651.     procedure CMParentCtl3DChanged(var Message: TMessage); message CM_PARENTCTL3DCHANGED;
  652.     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  653.     procedure CMShowHintChanged(var Message: TMessage); message CM_SHOWHINTCHANGED;
  654.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  655.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  656.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  657.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  658.     procedure CMWinIniChange(var Message: TWMWinIniChange); message CM_WININICHANGE;
  659.     procedure CMFontChange(var Message: TMessage); message CM_FONTCHANGE;
  660.     procedure CMTimeChange(var Message: TMessage); message CM_TIMECHANGE;
  661.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  662.     procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
  663.     procedure CNKeyUp(var Message: TWMKeyUp); message CN_KEYUP;
  664.     procedure CNChar(var Message: TWMChar); message CN_CHAR;
  665.     procedure CNSysKeyDown(var Message: TWMKeyDown); message CN_SYSKEYDOWN;
  666.     procedure CNSysChar(var Message: TWMChar); message CN_SYSCHAR;
  667.     procedure CMControlListChange(var Message: TMessage); message CM_CONTROLLISTCHANGE;
  668.     procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;
  669.     procedure CMInvalidate(var Message: TMessage); message CM_INVALIDATE;
  670.   protected
  671.     FDoubleBuffered: Boolean;
  672.     FInImeComposition: Boolean;
  673.     procedure AlignControls(AControl: TControl; var Rect: TRect); virtual;
  674.     procedure ChangeScale(M, D: Integer); override;
  675.     procedure CreateHandle; virtual;
  676.     procedure CreateParams(var Params: TCreateParams); virtual;
  677.     procedure CreateSubClass(var Params: TCreateParams;
  678.       ControlClassName: PChar);
  679.     procedure CreateWindowHandle(const Params: TCreateParams); virtual;
  680.     procedure CreateWnd; virtual;
  681.     procedure DefaultHandler(var Message); override;
  682.     procedure DestroyHandle;
  683.     procedure DestroyWindowHandle; virtual;
  684.     procedure DestroyWnd; virtual;
  685.     procedure DoEnter; dynamic;
  686.     procedure DoExit; dynamic;
  687.     function DoKeyDown(var Message: TWMKey): Boolean;
  688.     function DoKeyPress(var Message: TWMKey): Boolean;
  689.     function DoKeyUp(var Message: TWMKey): Boolean;
  690.     function FindNextControl(CurControl: TWinControl;
  691.       GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
  692.     procedure FixupTabList;
  693.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  694.     function GetClientOrigin: TPoint; override;
  695.     function GetClientRect: TRect; override;
  696.     function GetDeviceContext(var WindowHandle: HWnd): HDC; override;
  697.     function GetParentHandle: HWnd;
  698.     function GetTopParentHandle: HWnd;
  699.     function IsControlMouseMsg(var Message: TWMMouse): Boolean;
  700.     procedure KeyDown(var Key: Word; Shift: TShiftState); dynamic;
  701.     procedure KeyUp(var Key: Word; Shift: TShiftState); dynamic;
  702.     procedure KeyPress(var Key: Char); dynamic;
  703.     procedure MainWndProc(var Message: TMessage);
  704.     procedure NotifyControls(Msg: Word);
  705.     procedure PaintControls(DC: HDC; First: TControl);
  706.     procedure PaintHandler(var Message: TWMPaint);
  707.     procedure PaintWindow(DC: HDC); virtual;
  708.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  709.     procedure ReadState(Reader: TReader); override;
  710.     procedure RecreateWnd;
  711.     procedure ResetIme;
  712.     function ResetImeComposition(Action: DWORD): Boolean;
  713.     procedure ScaleControls(M, D: Integer);
  714.     procedure SelectFirst;
  715.     procedure SelectNext(CurControl: TWinControl;
  716.       GoForward, CheckTabStop: Boolean);
  717.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  718.     procedure SetIme;
  719.     function SetImeCompositionWindow(hWnd: HWND; Font: TFont;
  720.       XPos, YPos: Integer): Boolean;
  721.     procedure SetZOrder(TopMost: Boolean); override;
  722.     procedure ShowControl(AControl: TControl); virtual;
  723.     procedure WndProc(var Message: TMessage); override;
  724.     property Ctl3D: Boolean read FCtl3D write SetCtl3D stored IsCtl3DStored;
  725.     property DefWndProc: Pointer read FDefWndProc write FDefWndProc;
  726.     property ImeMode: TImeMode read FImeMode write FImeMode default imDontCare;
  727.     property ImeName: TImeName read FImeName write FImeName;
  728.     property ParentCtl3D: Boolean read FParentCtl3D write SetParentCtl3D default True;
  729.     property WindowHandle: HWnd read FHandle write FHandle;
  730.     property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
  731.     property OnExit: TNotifyEvent read FOnExit write FOnExit;
  732.     property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
  733.     property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
  734.     property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;
  735.   public
  736.     constructor Create(AOwner: TComponent); override;
  737.     constructor CreateParented(ParentWindow: HWnd);
  738.     destructor Destroy; override;
  739.     procedure Broadcast(var Message);
  740.     function CanFocus: Boolean;
  741.     function ContainsControl(Control: TControl): Boolean;
  742.     function ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  743.     procedure DisableAlign;
  744.     procedure EnableAlign;
  745.     function Focused: Boolean;
  746.     procedure GetTabOrderList(List: TList); dynamic;
  747.     function HandleAllocated: Boolean;
  748.     procedure HandleNeeded;
  749.     procedure InsertControl(AControl: TControl);
  750.     procedure Invalidate; override;
  751.     procedure PaintTo(DC: HDC; X, Y: Integer);
  752.     procedure RemoveControl(AControl: TControl);
  753.     procedure Realign;
  754.     procedure Repaint; override;
  755.     procedure ScaleBy(M, D: Integer);
  756.     procedure ScrollBy(DeltaX, DeltaY: Integer);
  757.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  758.     procedure SetFocus; virtual;
  759.     procedure Update; override;
  760.     procedure UpdateControlState;
  761.     property Brush: TBrush read FBrush;
  762.     property Controls[Index: Integer]: TControl read GetControl;
  763.     property ControlCount: Integer read GetControlCount;
  764.     property Handle: HWnd read GetHandle;
  765.     property ParentWindow: HWnd read FParentWindow write SetParentWindow;
  766.     property Showing: Boolean read FShowing;
  767.     property TabOrder: TTabOrder read GetTabOrder write SetTabOrder default -1;
  768.     property TabStop: Boolean read FTabStop write SetTabStop default False;
  769.   published
  770.     property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
  771.   end;
  772.  
  773.   TWinControlClass = class of TWinControl;
  774.  
  775.   TGraphicControl = class(TControl)
  776.   private
  777.     FCanvas: TCanvas;
  778.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  779.   protected
  780.     procedure Paint; virtual;
  781.     property Canvas: TCanvas read FCanvas;
  782.   public
  783.     constructor Create(AOwner: TComponent); override;
  784.     destructor Destroy; override;
  785.   end;
  786.  
  787.   TCustomControl = class(TWinControl)
  788.   private
  789.     FCanvas: TCanvas;
  790.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  791.   protected
  792.     procedure Paint; virtual;
  793.     procedure PaintWindow(DC: HDC); override;
  794.     property Canvas: TCanvas read FCanvas;
  795.   public
  796.     constructor Create(AOwner: TComponent); override;
  797.     destructor Destroy; override;
  798.   end;
  799.  
  800.   THintWindow = class(TCustomControl)
  801.   private
  802.     procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
  803.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  804.   protected
  805.     procedure CreateParams(var Params: TCreateParams); override;
  806.     procedure Paint; override;
  807.   public
  808.     constructor Create(AOwner: TComponent); override;
  809.     procedure ActivateHint(Rect: TRect; const AHint: string); virtual;
  810.     function IsHintMsg(var Msg: TMsg): Boolean; virtual;
  811.     procedure ReleaseHandle;
  812.     property Caption;
  813.     property Color;
  814.     property Canvas;
  815.   end;
  816.  
  817.   THintWindowClass = class of THintWindow;
  818.  
  819. { TChangeLink }
  820.  
  821.   TChangeLink = class(TObject)
  822.   private
  823.     FSender: TCustomImageList;
  824.     FOnChange: TNotifyEvent;
  825.   public
  826.     destructor Destroy; override;
  827.     procedure Change; dynamic;
  828.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  829.     property Sender: TCustomImageList read FSender write FSender;
  830.   end;
  831.  
  832.   { TCustomImageList }
  833.  
  834.   TDrawingStyle = (dsFocus, dsSelected, dsNormal, dsTransparent);
  835.   TImageType = (itImage, itMask);
  836.   TResType = (rtBitmap, rtCursor, rtIcon);
  837.   TOverlay = 0..3;
  838.   TLoadResource = (lrDefaultColor, lrDefaultSize, lrFromFile,
  839.     lrMap3DColors, lrTransparent, lrMonoChrome);
  840.   TLoadResources = set of TLoadResource;
  841.  
  842.   TCustomImageList = class(TComponent)
  843.   private
  844.     FHeight: Integer;
  845.     FWidth: Integer;
  846.     FAllocBy: Integer;
  847.     FHandle: HImageList;
  848.     FDrawingStyle: TDrawingStyle;
  849.     FMasked: Boolean;
  850.     FShareImages: Boolean;
  851.     FImageType: TImageType;
  852.     FBkColor: TColor;
  853.     FBlendColor: TColor;
  854.     FClients: TList;
  855.     FDragHandle: HWND;
  856.     FDragging: Boolean;
  857.     FDragCursor: TCursor;
  858.     FBitmap: TBitmap;
  859.     FOnChange: TNotifyEvent;
  860.     procedure AssignTo(Dest: TPersistent); override;
  861.     procedure InitBitmap;
  862.     procedure CheckImage(Image: TGraphic);
  863.     procedure CombineDragCursor;
  864.     procedure CopyImages(Value: HImageList);
  865.     procedure CreateImageList;
  866.     function Equal(IL: TCustomImageList): Boolean;
  867.     procedure FreeHandle;
  868.     function GetCount: Integer;
  869.     function GetBkColor: TColor;
  870.     function GetHandle: HImageList;
  871.     function GetImageHandle(Image: TBitmap): HBITMAP;
  872.     procedure InsertImage(Index: Integer; Image, Mask: TBitmap; MaskColor: TColor);
  873.     procedure ReadData(Stream: TStream);
  874.     procedure SetBkColor(Value: TColor);
  875.     procedure SetDragCursor(Value: TCursor);
  876.     procedure SetHandle(Value: HImageList);
  877.     procedure SetHeight(Value: Integer);
  878.     procedure SetNewDimensions(Value: HImageList);
  879.     procedure SetWidth(Value: Integer);
  880.     procedure WriteData(Stream: TStream);
  881.     procedure ReadD2Stream(Stream: TStream);
  882.     procedure ReadD3Stream(Stream: TStream);
  883.   protected
  884.     procedure Change; dynamic;
  885.     procedure DefineProperties(Filer: TFiler); override;
  886.     procedure GetImages(Index: Integer; Image, Mask: TBitmap);
  887.     procedure HandleNeeded;
  888.     procedure Initialize;
  889.     property BlendColor: TColor read FBlendColor write FBlendColor default clNone;
  890.     property BkColor: TColor read GetBkColor write SetBkColor default clNone;
  891.     property AllocBy: Integer read FAllocBy write FAllocBy default 4;
  892.     property DrawingStyle: TDrawingStyle read FDrawingStyle write FDrawingStyle default dsNormal;
  893.     property Height: Integer read FHeight write SetHeight default 16;
  894.     property ImageType: TImageType read FImageType write FImageType default itImage;
  895.     property Masked: Boolean read FMasked write FMasked default True;
  896.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  897.     property ShareImages: Boolean read FShareImages write FShareImages default False;
  898.     property Width: Integer read FWidth write SetWidth default 16;
  899.   public
  900.     constructor Create(AOwner: TComponent); override;
  901.     constructor CreateSize(AWidth, AHeight: Integer);
  902.     destructor Destroy; override;
  903.     procedure Assign(Source: TPersistent); override;
  904.     function Add(Image, Mask: TBitmap): Integer;
  905.     function AddIcon(Image: TIcon): Integer;
  906.     procedure AddImages(Value: TCustomImageList);
  907.     function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  908.     function BeginDrag(Window: HWND; X, Y: Integer): Boolean;
  909.     procedure Clear;
  910.     procedure Delete(Index: Integer);
  911.     function DragLock(Window: HWND; XPos, YPos: Integer): Boolean;
  912.     function DragMove(X, Y: Integer): Boolean;
  913.     procedure DragUnlock;
  914.     procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);
  915.     procedure DrawOverlay(Canvas: TCanvas; X, Y: Integer;
  916.       ImageIndex: Integer; Overlay: TOverlay);
  917.     function EndDrag: Boolean;
  918.     function FileLoad(ResType: TResType; Name: string;
  919.       MaskColor: TColor): Boolean;
  920.     procedure GetBitmap(Index: Integer; Image: TBitmap);
  921.     function GetHotSpot: TPoint;
  922.     procedure GetIcon(Index: Integer; Image: TIcon);
  923.     function GetImageBitmap: HBITMAP;
  924.     function GetMaskBitmap: HBITMAP;
  925.     function GetResource(ResType: TResType; Name: string;
  926.       Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
  927.     function GetInstRes(Instance: THandle; ResType: TResType; Name: string;
  928.       Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
  929.     function HandleAllocated: Boolean;
  930.     procedure HideDragImage;
  931.     procedure Insert(Index: Integer; Image, Mask: TBitmap);
  932.     procedure InsertIcon(Index: Integer; Image: TIcon);
  933.     procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
  934.     procedure Move(CurIndex, NewIndex: Integer);
  935.     function Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
  936.     procedure RegisterChanges(Value: TChangeLink);
  937.     function ResourceLoad(ResType: TResType; Name: string;
  938.       MaskColor: TColor): Boolean;
  939.     function ResInstLoad(Instance: THandle; ResType: TResType; Name: string;
  940.       MaskColor: TColor): Boolean;
  941.     procedure Replace(Index: Integer; Image, Mask: TBitmap);
  942.     procedure ReplaceIcon(Index: Integer; Image: TIcon);
  943.     procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
  944.     function SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean;
  945.     procedure ShowDragImage;
  946.     procedure UnRegisterChanges(Value: TChangeLink);
  947.     property Count: Integer read GetCount;
  948.     property DragCursor: TCursor read FDragCursor write SetDragCursor;
  949.     property Dragging: Boolean read FDragging;
  950.     property Handle: HImageList read GetHandle write SetHandle;
  951.   end;
  952.  
  953. { TImageList }
  954.   TImageList = class(TCustomImageList)
  955.   published
  956.     property BlendColor;
  957.     property BkColor;
  958.     property AllocBy;
  959.     property DrawingStyle;
  960.     property Height;
  961.     property ImageType;
  962.     property Masked;
  963.     property OnChange;
  964.     property ShareImages;
  965.     property Width;
  966.   end;
  967.  
  968. function IsDragObject(Sender: TObject): Boolean;
  969. function FindControl(Handle: HWnd): TWinControl;
  970. function FindVCLWindow(const Pos: TPoint): TWinControl;
  971. function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  972. function GetCaptureControl: TControl;
  973. procedure SetCaptureControl(Control: TControl);
  974. procedure CancelDrag;
  975.  
  976. function CursorToString(Cursor: TCursor): string;
  977. function StringToCursor(const S: string): TCursor;
  978. procedure GetCursorValues(Proc: TGetStrProc);
  979. function CursorToIdent(Cursor: Longint; var Ident: string): Boolean;
  980. function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean;
  981.  
  982. function GetShortHint(const Hint: string): string;
  983. function GetLongHint(const Hint: string): string;
  984.  
  985. var
  986.   CreationControl: TWinControl = nil;
  987.  
  988. function InitWndProc(HWindow: HWnd; Message, WParam: Longint;
  989.   LParam: Longint): Longint; stdcall;
  990.  
  991. const
  992.   CTL3D_ALL = $FFFF;
  993.  
  994. var
  995.   NewStyleControls: Boolean;
  996.  
  997. function SendAppMessage(Msg: Cardinal; WParam, LParam: Longint): Longint;
  998. procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
  999.  
  1000. procedure SetImeMode(Handle: HWnd; Mode: TImeMode);
  1001. function Win32NLSEnableIME(Handle: HWnd; Enable: Boolean): Boolean;
  1002. function Imm32GetContext(hWnd: HWND): HIMC;
  1003. function Imm32ReleaseContext(hWnd: HWND; hImc: HIMC): Boolean;
  1004. function Imm32GetConversionStatus(hImc: HIMC; var Conversion, Sentence: DWORD): Boolean;
  1005. function Imm32SetConversionStatus(hImc: HIMC; Conversion, Sentence: DWORD): Boolean;
  1006. function Imm32SetOpenStatus(hImc: HIMC; fOpen: Boolean): Boolean;
  1007. function Imm32SetCompositionWindow(hImc: HIMC; lpCompForm: PCOMPOSITIONFORM): Boolean;
  1008. function Imm32SetCompositionFont(hImc: HIMC; lpLogfont: PLOGFONTA): Boolean;
  1009. function Imm32GetCompositionString(hImc: HIMC; dWord1: DWORD; lpBuf: pointer; dwBufLen: DWORD): Longint;
  1010. function Imm32IsIME(hKl: HKL): Boolean;
  1011. function Imm32NotifyIME(hImc: HIMC; dwAction, dwIndex, dwValue: DWORD): Boolean;
  1012.  
  1013. implementation
  1014.  
  1015. uses Consts, Forms, ActiveX;
  1016.  
  1017. var
  1018.   WindowAtom: TAtom;
  1019.   ControlAtom: TAtom;
  1020.  
  1021. { TStreamAdapter }
  1022. { Maps VCL TStream to OLE IStream }
  1023.  
  1024. type
  1025.   TStreamAdapter = class(TInterfacedObject, IStream)
  1026.   private
  1027.     FStream: TStream;
  1028.   public
  1029.     constructor Create(Stream: TStream);
  1030.     function Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
  1031.       stdcall;
  1032.     function Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
  1033.       stdcall;
  1034.     function Seek(dlibMove: Largeint; dwOrigin: Longint;
  1035.       out libNewPosition: Largeint): HResult; stdcall;
  1036.     function SetSize(libNewSize: Largeint): HResult; stdcall;
  1037.     function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  1038.       out cbWritten: Largeint): HResult; stdcall;
  1039.     function Commit(grfCommitFlags: Longint): HResult; stdcall;
  1040.     function Revert: HResult; stdcall;
  1041.     function LockRegion(libOffset: Largeint; cb: Largeint;
  1042.       dwLockType: Longint): HResult; stdcall;
  1043.     function UnlockRegion(libOffset: Largeint; cb: Largeint;
  1044.       dwLockType: Longint): HResult; stdcall;
  1045.     function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
  1046.       stdcall;
  1047.     function Clone(out stm: IStream): HResult; stdcall;
  1048.   end;
  1049.  
  1050. constructor TStreamAdapter.Create(Stream: TStream);
  1051. begin
  1052.   inherited Create;
  1053.   FStream := Stream;
  1054. end;
  1055.  
  1056. function TStreamAdapter.Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
  1057. var
  1058.   NumRead: Longint;
  1059. begin
  1060.   try
  1061.     if pv = Nil then
  1062.     begin
  1063.       Result := STG_E_INVALIDPOINTER;
  1064.       Exit;
  1065.     end;
  1066.     NumRead := FStream.Read(pv^, cb);
  1067.     if pcbRead <> Nil then pcbRead^ := NumRead;
  1068.     Result := S_OK;
  1069.   except
  1070.     Result := S_FALSE;
  1071.   end;
  1072. end;
  1073.  
  1074. function TStreamAdapter.Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
  1075. var
  1076.   NumWritten: Longint;
  1077. begin
  1078.   try
  1079.     if pv = Nil then
  1080.     begin
  1081.       Result := STG_E_INVALIDPOINTER;
  1082.       Exit;
  1083.     end;
  1084.     NumWritten := FStream.Write(pv^, cb);
  1085.     if pcbWritten <> Nil then pcbWritten^ := NumWritten;
  1086.     Result := S_OK;
  1087.   except
  1088.     Result := STG_E_CANTSAVE;
  1089.   end;
  1090. end;
  1091.  
  1092. function TStreamAdapter.Seek(dlibMove: Largeint; dwOrigin: Longint;
  1093.   out libNewPosition: Largeint): HResult;
  1094. begin
  1095.   try
  1096.     if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then
  1097.     begin
  1098.       Result := STG_E_INVALIDFUNCTION;
  1099.       Exit;
  1100.     end;
  1101.     libNewPosition := FStream.Seek(Trunc(dlibMove), dwOrigin);
  1102.     Result := S_OK;
  1103.   except
  1104.     Result := STG_E_INVALIDPOINTER;
  1105.   end;
  1106. end;
  1107.  
  1108. function TStreamAdapter.SetSize(libNewSize: Largeint): HResult;
  1109. begin
  1110.   try
  1111.     FStream.Size := Trunc(libNewSize);
  1112.     if libNewSize <> FStream.Size then
  1113.       Result := E_FAIL
  1114.     else
  1115.       Result := S_OK;
  1116.   except
  1117.     Result := E_UNEXPECTED;
  1118.   end;
  1119. end;
  1120.  
  1121. function TStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  1122.   out cbWritten: Largeint): HResult;
  1123. var
  1124.   Buffer: Pointer;
  1125.   Size, Written: Longint;
  1126. begin
  1127.   try
  1128.     Size := Trunc(cb);
  1129.     GetMem(Buffer, Size);
  1130.     try
  1131.       cbRead := FStream.Read(Buffer^, Size);
  1132.       stm.Write(Buffer, Size, @Written);
  1133.     finally
  1134.       FreeMem(Buffer, Size);
  1135.     end;
  1136.     cbWritten := Written;
  1137.     Result := S_OK;
  1138.   except
  1139.     Result := E_UNEXPECTED;
  1140.   end;
  1141. end;
  1142.  
  1143. function TStreamAdapter.Commit(grfCommitFlags: Longint): HResult;
  1144. begin
  1145.   Result := S_OK;
  1146. end;
  1147.  
  1148. function TStreamAdapter.Revert: HResult;
  1149. begin
  1150.   Result := STG_E_REVERTED;
  1151. end;
  1152.  
  1153. function TStreamAdapter.LockRegion(libOffset: Largeint; cb: Largeint;
  1154.   dwLockType: Longint): HResult;
  1155. begin
  1156.   Result := STG_E_INVALIDFUNCTION;
  1157. end;
  1158.  
  1159. function TStreamAdapter.UnlockRegion(libOffset: Largeint; cb: Largeint;
  1160.   dwLockType: Longint): HResult;
  1161. begin
  1162.   Result := STG_E_INVALIDFUNCTION;
  1163. end;
  1164.  
  1165. function TStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
  1166. begin
  1167.   try
  1168. {    if statstg = Nil then
  1169.     begin
  1170.       Result := E_INVALIDPOINTER;
  1171.       Exit;
  1172.     end;}
  1173.     with statstg do
  1174.     begin
  1175.       dwType := STGTY_STREAM;
  1176.       cbSize := FStream.Size;
  1177.       mTime.dwLowDateTime := 0;
  1178.       mTime.dwHighDateTime := 0;
  1179.       cTime.dwLowDateTime := 0;
  1180.       cTime.dwHighDateTime := 0;
  1181.       aTime.dwLowDateTime := 0;
  1182.       aTime.dwHighDateTime := 0;
  1183.       grfLocksSupported := LOCK_WRITE;
  1184.       Result := S_OK;
  1185.     end;
  1186.   except
  1187. //    statstg := Nil;
  1188.     Result := E_UNEXPECTED;
  1189.   end;
  1190. end;
  1191.  
  1192. function TStreamAdapter.Clone(out stm: IStream): HResult;
  1193. begin
  1194.   Result := E_NOTIMPL;
  1195. end;
  1196.  
  1197. { Initialization window procedure }
  1198.  
  1199. function InitWndProc(HWindow: HWnd; Message, WParam,
  1200.   LParam: Longint): Longint;
  1201. begin
  1202.   CreationControl.FHandle := HWindow;
  1203.   SetWindowLong(HWindow, GWL_WNDPROC,
  1204.     Longint(CreationControl.FObjectInstance));
  1205.   if (GetWindowLong(HWindow, GWL_STYLE) and WS_CHILD <> 0) and
  1206.     (GetWindowLong(HWindow, GWL_ID) = 0) then
  1207.     SetWindowLong(HWindow, GWL_ID, HWindow);
  1208.   SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl));
  1209.   SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl));
  1210.   asm
  1211.         PUSH    LParam
  1212.         PUSH    WParam
  1213.         PUSH    Message
  1214.         PUSH    HWindow
  1215.         MOV     EAX,CreationControl
  1216.         MOV     CreationControl,0
  1217.         CALL    [EAX].TWinControl.FObjectInstance
  1218.         MOV     Result,EAX
  1219.   end;
  1220. end;
  1221.  
  1222. { Find a TWinControl given a window handle }
  1223.  
  1224. function FindControl(Handle: HWnd): TWinControl;
  1225. begin
  1226.   Result := nil;
  1227.   if Handle <> 0 then
  1228.   begin
  1229.     Result := Pointer(GetProp(Handle, MakeIntAtom(ControlAtom)));
  1230.   end;
  1231. end;
  1232.  
  1233. { Send message to application object }
  1234.  
  1235. function SendAppMessage(Msg: Cardinal; WParam, LParam: Longint): Longint;
  1236. begin
  1237.   if Application.Handle <> 0 then
  1238.     Result := SendMessage(Application.Handle, Msg, WParam, LParam) else
  1239.     Result := 0;
  1240. end;
  1241.  
  1242. { Cursor translation function }
  1243.  
  1244. const
  1245.   DeadCursors = 1;
  1246.  
  1247. const
  1248.   Cursors: array[0..19] of TIdentMapEntry = (
  1249.     (Value: crDefault;      Name: 'crDefault'),
  1250.     (Value: crArrow;        Name: 'crArrow'),
  1251.     (Value: crCross;        Name: 'crCross'),
  1252.     (Value: crIBeam;        Name: 'crIBeam'),
  1253.     (Value: crSizeNESW;     Name: 'crSizeNESW'),
  1254.     (Value: crSizeNS;       Name: 'crSizeNS'),
  1255.     (Value: crSizeNWSE;     Name: 'crSizeNWSE'),
  1256.     (Value: crSizeWE;       Name: 'crSizeWE'),
  1257.     (Value: crUpArrow;      Name: 'crUpArrow'),
  1258.     (Value: crHourGlass;    Name: 'crHourGlass'),
  1259.     (Value: crDrag;         Name: 'crDrag'),
  1260.     (Value: crNoDrop;       Name: 'crNoDrop'),
  1261.     (Value: crHSplit;       Name: 'crHSplit'),
  1262.     (Value: crVSplit;       Name: 'crVSplit'),
  1263.     (Value: crMultiDrag;    Name: 'crMultiDrag'),
  1264.     (Value: crSQLWait;      Name: 'crSQLWait'),
  1265.     (Value: crNo;           Name: 'crNo'),
  1266.     (Value: crAppStart;     Name: 'crAppStart'),
  1267.     (Value: crHelp;         Name: 'crHelp'),
  1268.  
  1269.     { Dead cursors }
  1270.     (Value: crSize;         Name: 'crSize'));
  1271.  
  1272. function CursorToString(Cursor: TCursor): string;
  1273. begin
  1274.   if not CursorToIdent(Cursor, Result) then FmtStr(Result, '%d', [Cursor]);
  1275. end;
  1276.  
  1277. function StringToCursor(const S: string): TCursor;
  1278. var
  1279.   L: Longint;
  1280. begin
  1281.   if not IdentToCursor(S, L) then L := StrToInt(S);
  1282.   Result := L;
  1283. end;
  1284.  
  1285. procedure GetCursorValues(Proc: TGetStrProc);
  1286. var
  1287.   I: Integer;
  1288. begin
  1289.   for I := Low(Cursors) to High(Cursors) - DeadCursors do Proc(Cursors[I].Name);
  1290. end;
  1291.  
  1292. function CursorToIdent(Cursor: Longint; var Ident: string): Boolean;
  1293. begin
  1294.   Result := IntToIdent(Cursor, Ident, Cursors);
  1295. end;
  1296.  
  1297. function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean;
  1298. begin
  1299.   Result := IdentToInt(Ident, Cursor, Cursors);
  1300. end;
  1301.  
  1302. function GetShortHint(const Hint: string): string;
  1303. var
  1304.   I: Integer;
  1305. begin
  1306.   I := AnsiPos('|', Hint);
  1307.   if I = 0 then
  1308.     Result := Hint else
  1309.     Result := Copy(Hint, 1, I - 1);
  1310. end;
  1311.  
  1312. function GetLongHint(const Hint: string): string;
  1313. var
  1314.   I: Integer;
  1315. begin
  1316.   I := AnsiPos('|', Hint);
  1317.   if I = 0 then
  1318.     Result := Hint else
  1319.     Result := Copy(Hint, I + 1, Maxint);
  1320. end;
  1321.  
  1322. { Mouse capture management }
  1323.  
  1324. var
  1325.   CaptureControl: TControl = nil;
  1326.  
  1327. function GetCaptureControl: TControl;
  1328. begin
  1329.   Result := FindControl(GetCapture);
  1330.   if (Result <> nil) and (CaptureControl <> nil) and
  1331.     (CaptureControl.Parent = Result) then Result := CaptureControl;
  1332. end;
  1333.  
  1334. procedure SetCaptureControl(Control: TControl);
  1335. begin
  1336.   ReleaseCapture;
  1337.   CaptureControl := nil;
  1338.   if Control <> nil then
  1339.   begin
  1340.     if not (Control is TWinControl) then
  1341.     begin
  1342.       if Control.Parent = nil then Exit;
  1343.       CaptureControl := Control;
  1344.       Control := Control.Parent;
  1345.     end;
  1346.     SetCapture(TWinControl(Control).Handle);
  1347.   end;
  1348. end;
  1349.  
  1350. { Drag-and-drop management }
  1351.  
  1352. var
  1353.   DragControl: TControl;
  1354.   DragObject: TDragObject;
  1355.   DragFreeObject: Boolean;
  1356.   DragTarget: Pointer;
  1357.   DragHandle: HWND;
  1358.   DragCapture: HWND;
  1359.   DragStartPos: TPoint;
  1360.   DragPos: TPoint;
  1361.   DragSaveCursor: HCURSOR;
  1362.   DragActive: Boolean;
  1363.   DragImageList: TCustomImageList;
  1364.  
  1365. { TDragObject }
  1366.  
  1367. procedure DragTo(const Pos: TPoint); forward;
  1368. procedure DragDone(Drop: Boolean); forward;
  1369.  
  1370. function IsDragObject(Sender: TObject): Boolean;
  1371. var
  1372.   SenderClass: TClass;
  1373. begin
  1374.   SenderClass := Sender.ClassType;
  1375.   Result := True;
  1376.   while SenderClass <> nil do
  1377.     if SenderClass.ClassName = TDragObject.ClassName then
  1378.       Exit else
  1379.       SenderClass := SenderClass.ClassParent;
  1380.   Result := False;
  1381. end;
  1382.  
  1383. function TDragObject.Instance: THandle;
  1384. begin
  1385.   Result := SysInit.HInstance;
  1386. end;
  1387.  
  1388. function TDragObject.GetName: string;
  1389. begin
  1390.   Result := ClassName;
  1391. end;
  1392.  
  1393. function TDragObject.GetDragImages: TCustomImageList;
  1394. begin
  1395.   Result := nil;
  1396. end;
  1397.  
  1398. function TDragObject.Capture: HWND;
  1399. begin
  1400.   Result := AllocateHWND(MouseMsg);
  1401.   SetCapture(Result);
  1402. end;
  1403.  
  1404. procedure TDragObject.ReleaseCapture(Handle: HWND);
  1405. begin
  1406.   Windows.ReleaseCapture;
  1407.   DeallocateHWND(Handle);
  1408. end;
  1409.  
  1410. function TDragObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
  1411. begin
  1412.   if Accepted then
  1413.     Result := crDrag else
  1414.     Result := crNoDrop;
  1415. end;
  1416.  
  1417. procedure TDragObject.Finished(Target: TObject; X, Y: Integer; Accepted: Boolean);
  1418. begin
  1419. end;
  1420.  
  1421. procedure TDragObject.HideDragImage;
  1422. begin
  1423. end;
  1424.  
  1425. procedure TDragObject.ShowDragImage;
  1426. begin
  1427. end;
  1428.  
  1429. procedure TDragObject.MouseMsg(var Msg: TMessage);
  1430. var
  1431.   P: TPoint;
  1432. begin
  1433.   try
  1434.     case Msg.Msg of
  1435.       WM_MOUSEMOVE:
  1436.         begin
  1437.           P := SmallPointToPoint(TWMMouse(Msg).Pos);
  1438.           ClientToScreen(DragCapture, P);
  1439.           DragTo(P);
  1440.         end;
  1441.       WM_LBUTTONUP:
  1442.         DragDone(True);
  1443.     end;
  1444.   except
  1445.     if DragControl <> nil then DragDone(False);
  1446.     raise;
  1447.   end;
  1448. end;
  1449.  
  1450. { TDragControlObject }
  1451.  
  1452. constructor TDragControlObject.Create(AControl: TControl);
  1453. begin
  1454.   FControl := AControl;
  1455. end;
  1456.  
  1457. function TDragControlObject.GetDragImages: TCustomImageList;
  1458. begin
  1459.   Result := Control.GetDragImages;
  1460. end;
  1461.  
  1462. procedure TDragControlObject.HideDragImage;
  1463. begin
  1464.   if Control.GetDragImages <> nil then
  1465.     Control.GetDragImages.HideDragImage;
  1466. end;
  1467.  
  1468. procedure TDragControlObject.ShowDragImage;
  1469. begin
  1470.   if Control.GetDragImages <> nil then
  1471.     Control.GetDragImages.ShowDragImage;
  1472. end;
  1473.  
  1474. function TDragControlObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
  1475. begin
  1476.   if Accepted then
  1477.     Result := Control.DragCursor else
  1478.     Result := crNoDrop;
  1479. end;
  1480.  
  1481. procedure TDragControlObject.Finished(Target: TObject; X, Y: Integer; Accepted: Boolean);
  1482. begin
  1483.   if not Accepted then Control.DragCanceled;
  1484.   Control.DoEndDrag(Target, X, Y);
  1485. end;
  1486.  
  1487. { Drag drop functions }
  1488.  
  1489. function DragMessage(Handle: HWND; Msg: TDragMessage;
  1490.   Source: TDragObject; Target: Pointer; const Pos: TPoint): Longint;
  1491. var
  1492.   DragRec: TDragRec;
  1493. begin
  1494.   Result := 0;
  1495.   if Handle <> 0 then
  1496.   begin
  1497.     DragRec.Pos := Pos;
  1498.     DragRec.Target := Target;
  1499.     DragRec.Source := Source;
  1500.     Result := SendMessage(Handle, CM_DRAG, Longint(Msg), Longint(@DragRec));
  1501.   end;
  1502. end;
  1503.  
  1504. function IsDelphiHandle(Handle: HWND): Boolean;
  1505. begin
  1506.   Result := (Handle <> 0) and
  1507.     (GetProp(Handle, MakeIntAtom(WindowAtom)) <> 0);
  1508. end;
  1509.  
  1510. function DragFindWindow(const Pos: TPoint): HWND;
  1511. begin
  1512.   Result := WindowFromPoint(Pos);
  1513.   while Result <> 0 do
  1514.     if not IsDelphiHandle(Result) then
  1515.       Result := GetParent(Result) else
  1516.       Exit;
  1517. end;
  1518.  
  1519. function DragFindTarget(const Pos: TPoint; var Handle: HWND): Pointer;
  1520. begin
  1521.   Handle := DragFindWindow(Pos);
  1522.   Result := Pointer(DragMessage(Handle, dmFindTarget, DragObject, nil, Pos));
  1523. end;
  1524.  
  1525. function DoDragOver(DragMsg: TDragMessage): Boolean;
  1526. begin
  1527.   Result := False;
  1528.   if DragTarget <> nil then
  1529.     Result := LongBool(DragMessage(DragHandle, DragMsg, DragObject, DragTarget,
  1530.       DragPos));
  1531. end;
  1532.  
  1533. procedure DragTo(const Pos: TPoint);
  1534. const
  1535.   Threshold = 5;
  1536. var
  1537.   DragCursor: TCursor;
  1538.   Target: TControl;
  1539.   TargetHandle: HWND;
  1540. begin
  1541.   if DragActive or (Abs(DragStartPos.X - Pos.X) >= Threshold) or
  1542.     (Abs(DragStartPos.Y - Pos.Y) >= Threshold) then
  1543.   begin
  1544.     if not DragActive and (DragImageList <> nil) then
  1545.       with DragStartPos do DragImageList.BeginDrag(GetDeskTopWindow, X, Y);
  1546.     DragActive := True;
  1547.     Target := DragFindTarget(Pos, TargetHandle);
  1548.     if Target <> DragTarget then
  1549.     begin
  1550.       DoDragOver(dmDragLeave);
  1551.       DragTarget := Target;
  1552.       DragHandle := TargetHandle;
  1553.       DragPos := Pos;
  1554.       DoDragOver(dmDragEnter);
  1555.     end;
  1556.     DragPos := Pos;
  1557.     DragCursor := DragObject.GetDragCursor(DoDragOver(dmDragMove), Pos.X, Pos.Y);
  1558.     if DragImageList <> nil then
  1559.     begin
  1560.       if (Target = nil) or (csDisplayDragImage in Target.ControlStyle) then
  1561.       begin
  1562.         DragImageList.DragCursor := DragCursor;
  1563.         if not DragImageList.Dragging then
  1564.           DragImageList.BeginDrag(GetDeskTopWindow, Pos.X, Pos.Y)
  1565.         else DragImageList.DragMove(Pos.X, Pos.Y);
  1566.       end
  1567.       else begin
  1568.         DragImageList.EndDrag;
  1569.         Windows.SetCursor(Screen.Cursors[DragCursor]);
  1570.       end;
  1571.     end else
  1572.       Windows.SetCursor(Screen.Cursors[DragCursor]);
  1573.   end;
  1574. end;
  1575.  
  1576. procedure DragInit(ADragObject: TDragObject; Immediate: Boolean);
  1577. begin
  1578.   DragObject := ADragObject;
  1579.   DragTarget := nil;
  1580.   GetCursorPos(DragStartPos);
  1581.   DragSaveCursor := Windows.GetCursor;
  1582.   DragActive := Immediate;
  1583.   DragImageList := DragObject.GetDragImages;
  1584.   DragCapture := DragObject.Capture;
  1585.   if DragActive and (DragImageList <> nil) then
  1586.     with DragStartPos do DragImageList.BeginDrag(GetDeskTopWindow, X, Y);
  1587.   if DragActive then DragTo(DragStartPos);
  1588. end;
  1589.  
  1590. procedure DragInitControl(Control: TControl; Immediate: Boolean);
  1591. var
  1592.   DragObject: TDragObject;
  1593. begin
  1594.   DragControl := Control;
  1595.   try
  1596.     DragObject := nil;
  1597.     DragFreeObject := False;
  1598.     Control.DoStartDrag(DragObject);
  1599.     if DragObject = nil then
  1600.     begin
  1601.       DragObject := TDragControlObject.Create(Control);
  1602.       DragFreeObject := True;
  1603.     end;
  1604.     DragInit(DragObject, Immediate);
  1605.   except
  1606.     DragControl := nil;
  1607.     raise;
  1608.   end;
  1609. end;
  1610.  
  1611. procedure DragDone(Drop: Boolean);
  1612. var
  1613.   DragSave: TDragObject;
  1614.   Accepted: Boolean;
  1615.   DragMsg: TDragMessage;
  1616.   TargetPos: TPoint;
  1617. begin
  1618.   DragSave := nil;
  1619.   DragControl := nil;
  1620.   try
  1621.     DragObject.ReleaseCapture(DragCapture);
  1622.     DragSave := DragObject;
  1623.     if DragImageList <> nil then
  1624.       DragImageList.EndDrag else
  1625.       Windows.SetCursor(DragSaveCursor);
  1626.     try
  1627.       if TObject(DragTarget) is TControl then
  1628.         TargetPos := TControl(DragTarget).ScreenToClient(DragPos) else
  1629.         TargetPos := DragPos;
  1630.       Accepted := DragActive and DoDragOver(dmDragLeave) and Drop;
  1631.       DragObject := nil;
  1632.       DragMsg := dmDragDrop;
  1633.       if not Accepted then
  1634.       begin
  1635.         DragMsg := dmDragCancel;
  1636.         DragPos.X := 0;
  1637.         DragPos.Y := 0;
  1638.         TargetPos.X := 0;
  1639.         TargetPos.Y := 0;
  1640.       end;
  1641.       DragMessage(DragHandle, DragMsg, DragSave, DragTarget, DragPos);
  1642.       DragSave.Finished(DragTarget, TargetPos.X, TargetPos.Y, Accepted);
  1643.       DragTarget := nil;
  1644.     finally
  1645.       DragObject := nil;
  1646.     end;
  1647.   finally
  1648.     if DragFreeObject then DragSave.Free;
  1649.   end;
  1650. end;
  1651.  
  1652. procedure CancelDrag;
  1653. begin
  1654.   if DragObject <> nil then DragDone(False);
  1655.   DragControl := nil;
  1656. end;
  1657.  
  1658. function FindVCLWindow(const Pos: TPoint): TWinControl;
  1659. var
  1660.   Handle: HWND;
  1661. begin
  1662.   Handle := WindowFromPoint(Pos);
  1663.   Result := nil;
  1664.   while Handle <> 0 do
  1665.   begin
  1666.     Result := FindControl(Handle);
  1667.     if Result <> nil then Exit;
  1668.     Handle := GetParent(Handle);
  1669.   end;
  1670. end;
  1671.  
  1672. function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  1673. var
  1674.   Window: TWinControl;
  1675.   Control: TControl;
  1676. begin
  1677.   Result := nil;
  1678.   Window := FindVCLWindow(Pos);
  1679.   if Window <> nil then
  1680.   begin
  1681.     Result := Window;
  1682.     Control := Window.ControlAtPos(Window.ScreenToClient(Pos), AllowDisabled);
  1683.     if Control <> nil then Result := Control;
  1684.   end;
  1685. end;
  1686.  
  1687. { List helpers }
  1688.  
  1689. procedure ListAdd(var List: TList; Item: Pointer);
  1690. begin
  1691.   if List = nil then List := TList.Create;
  1692.   List.Add(Item);
  1693. end;
  1694.  
  1695. procedure ListRemove(var List: TList; Item: Pointer);
  1696. begin
  1697.   List.Remove(Item);
  1698.   if List.Count = 0 then
  1699.   begin
  1700.     List.Free;
  1701.     List := nil;
  1702.   end;
  1703. end;
  1704.  
  1705. { Miscellaneous routines }
  1706.  
  1707. procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
  1708. var
  1709.   P: TPoint;
  1710. begin
  1711.   GetWindowOrgEx(DC, P);
  1712.   SetWindowOrgEx(DC, P.X - DX, P.Y - DY, nil);
  1713. end;
  1714.  
  1715. { Object implementations }
  1716.  
  1717. { TControlCanvas }
  1718.  
  1719. var
  1720.   CanvasList: TList;
  1721.  
  1722. procedure FreeDeviceContext;
  1723. begin
  1724.   TControlCanvas(CanvasList[0]).FreeHandle;
  1725. end;
  1726.  
  1727. procedure FreeDeviceContexts;
  1728. begin
  1729.   while CanvasList.Count > 0 do FreeDeviceContext;
  1730. end;
  1731.  
  1732. destructor TControlCanvas.Destroy;
  1733. begin
  1734.   FreeHandle;
  1735.   inherited Destroy;
  1736. end;
  1737.  
  1738. procedure TControlCanvas.CreateHandle;
  1739. begin
  1740.   if FControl = nil then inherited CreateHandle else
  1741.   begin
  1742.     if FDeviceContext = 0 then
  1743.     begin
  1744.       if CanvasList.Count = CanvasList.Capacity then FreeDeviceContext;
  1745.       FDeviceContext := FControl.GetDeviceContext(FWindowHandle);
  1746.       CanvasList.Add(Self);
  1747.     end;
  1748.     Handle := FDeviceContext;
  1749.   end;
  1750. end;
  1751.  
  1752. procedure TControlCanvas.FreeHandle;
  1753. begin
  1754.   if FDeviceContext <> 0 then
  1755.   begin
  1756.     Handle := 0;
  1757.     CanvasList.Remove(Self);
  1758.     ReleaseDC(FWindowHandle, FDeviceContext);
  1759.     FDeviceContext := 0;
  1760.   end;
  1761. end;
  1762.  
  1763. procedure TControlCanvas.SetControl(AControl: TControl);
  1764. begin
  1765.   if FControl <> AControl then
  1766.   begin
  1767.     FreeHandle;
  1768.     FControl := AControl;
  1769.   end;
  1770. end;
  1771.  
  1772. { TControl }
  1773.  
  1774. constructor TControl.Create(AOwner: TComponent);
  1775. begin
  1776.   inherited Create(AOwner);
  1777.   FWindowProc := WndProc;
  1778.   FControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks];
  1779.   FFont := TFont.Create;
  1780.   FFont.OnChange := FontChanged;
  1781.   FColor := clWindow;
  1782.   FVisible := True;
  1783.   FEnabled := True;
  1784.   FParentFont := True;
  1785.   FParentColor := True;
  1786.   FParentShowHint := True;
  1787.   FIsControl := False;
  1788.   FDragCursor := crDrag;
  1789. end;
  1790.  
  1791. destructor TControl.Destroy;
  1792. begin
  1793.   Application.ControlDestroyed(Self);
  1794.   FFont.Free;
  1795.   StrDispose(FText);
  1796.   SetParent(nil);
  1797.   inherited Destroy;
  1798. end;
  1799.  
  1800. function TControl.GetDragImages: TCustomImageList;
  1801. begin
  1802.   Result := nil;
  1803. end;
  1804.  
  1805. function TControl.GetPalette: HPALETTE;
  1806. begin
  1807.   Result := 0;
  1808. end;
  1809.  
  1810. function TControl.HasParent: Boolean;
  1811. begin
  1812.   Result := FParent <> nil;
  1813. end;
  1814.  
  1815. function TControl.GetParentComponent: TComponent;
  1816. begin
  1817.   Result := Parent;
  1818. end;
  1819.  
  1820. procedure TControl.SetParentComponent(Value: TComponent);
  1821. begin
  1822.   if Value is TWinControl then SetParent(TWinControl(Value));
  1823. end;
  1824.  
  1825. function TControl.PaletteChanged(Foreground: Boolean): Boolean;
  1826. var
  1827.   OldPalette, Palette: HPALETTE;
  1828.   WindowHandle: HWnd;
  1829.   DC: HDC;
  1830. begin
  1831.   Result := False;
  1832.   if not Visible then Exit;
  1833.   Palette := GetPalette;
  1834.   if Palette <> 0 then
  1835.   begin
  1836.     DC := GetDeviceContext(WindowHandle);
  1837.     OldPalette := SelectPalette(DC, Palette, not Foreground);
  1838.     if RealizePalette(DC) <> 0 then Invalidate;
  1839.     SelectPalette(DC, OldPalette, True);
  1840.     ReleaseDC(WindowHandle, DC);
  1841.     Result := True;
  1842.   end;
  1843. end;
  1844.  
  1845. procedure TControl.SetDragMode(Value: TDragMode);
  1846. begin
  1847.   FDragMode := Value;
  1848. end;
  1849.  
  1850. procedure TControl.RequestAlign;
  1851. begin
  1852.   if Parent <> nil then Parent.AlignControl(Self);
  1853. end;
  1854.  
  1855. procedure TControl.ReadState(Reader: TReader);
  1856. begin
  1857.   Include(FControlState, csReadingState);
  1858.   if Reader.Parent is TWinControl then Parent := TWinControl(Reader.Parent);
  1859.   inherited ReadState(Reader);
  1860.   Exclude(FControlState, csReadingState);
  1861.   if Parent <> nil then
  1862.   begin
  1863.     Perform(CM_PARENTCOLORCHANGED, 0, 0);
  1864.     Perform(CM_PARENTFONTCHANGED, 0, 0);
  1865.     Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  1866.   end;
  1867. end;
  1868.  
  1869. procedure TControl.Notification(AComponent: TComponent;
  1870.   Operation: TOperation);
  1871. begin
  1872.   inherited Notification(AComponent, Operation);
  1873.   if (AComponent = PopupMenu) and (Operation = opRemove) then PopupMenu := nil;
  1874. end;
  1875.  
  1876. procedure TControl.SetAlign(Value: TAlign);
  1877. var
  1878.   OldAlign: TAlign;
  1879. begin
  1880.   if FAlign <> Value then
  1881.   begin
  1882.     OldAlign := FAlign;
  1883.     FAlign := Value;
  1884.     if not (csLoading in ComponentState) and
  1885.       ((OldAlign in [alTop, alBottom]) = (Value in [alRight, alLeft])) and
  1886.       not (OldAlign in [alNone, alClient]) and not (Value in [alNone, alClient]) then
  1887.       SetBounds(Left, Top, Height, Width);
  1888.   end;
  1889.   RequestAlign;
  1890. end;
  1891.  
  1892. procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  1893. begin
  1894.   if (ALeft <> FLeft) or (ATop <> FTop) or
  1895.     (AWidth <> FWidth) or (AHeight <> FHeight) then
  1896.   begin
  1897.     InvalidateControl(Visible, False);
  1898.     FLeft := ALeft;
  1899.     FTop := ATop;
  1900.     FWidth := AWidth;
  1901.     FHeight := AHeight;
  1902.     Invalidate;
  1903.     Perform(WM_WINDOWPOSCHANGED, 0, 0);
  1904.     RequestAlign;
  1905.   end;
  1906. end;
  1907.  
  1908. procedure TControl.SetLeft(Value: Integer);
  1909. begin
  1910.   SetBounds(Value, FTop, FWidth, FHeight);
  1911.   Include(FScalingFlags, sfLeft);
  1912. end;
  1913.  
  1914. procedure TControl.SetTop(Value: Integer);
  1915. begin
  1916.   SetBounds(FLeft, Value, FWidth, FHeight);
  1917.   Include(FScalingFlags, sfTop);
  1918. end;
  1919.  
  1920. procedure TControl.SetWidth(Value: Integer);
  1921. begin
  1922.   SetBounds(FLeft, FTop, Value, FHeight);
  1923.   Include(FScalingFlags, sfWidth);
  1924. end;
  1925.  
  1926. procedure TControl.SetHeight(Value: Integer);
  1927. begin
  1928.   SetBounds(FLeft, FTop, FWidth, Value);
  1929.   Include(FScalingFlags, sfHeight);
  1930. end;
  1931.  
  1932. function TControl.GetBoundsRect: TRect;
  1933. begin
  1934.   Result.Left := Left;
  1935.   Result.Top := Top;
  1936.   Result.Right := Left + Width;
  1937.   Result.Bottom := Top + Height;
  1938. end;
  1939.  
  1940. procedure TControl.SetBoundsRect(const Rect: TRect);
  1941. begin
  1942.   with Rect do SetBounds(Left, Top, Right - Left, Bottom - Top);
  1943. end;
  1944.  
  1945. function TControl.GetClientRect: TRect;
  1946. begin
  1947.   Result.Left := 0;
  1948.   Result.Top := 0;
  1949.   Result.Right := Width;
  1950.   Result.Bottom := Height;
  1951. end;
  1952.  
  1953. function TControl.GetClientWidth: Integer;
  1954. begin
  1955.   Result := ClientRect.Right;
  1956. end;
  1957.  
  1958. procedure TControl.SetClientWidth(Value: Integer);
  1959. begin
  1960.   SetClientSize(Point(Value, ClientHeight));
  1961. end;
  1962.  
  1963. function TControl.GetClientHeight: Integer;
  1964. begin
  1965.   Result := ClientRect.Bottom;
  1966. end;
  1967.  
  1968. procedure TControl.SetClientHeight(Value: Integer);
  1969. begin
  1970.   SetClientSize(Point(ClientWidth, Value));
  1971. end;
  1972.  
  1973. function TControl.GetClientOrigin: TPoint;
  1974. begin
  1975.   if Parent = nil then
  1976.     raise EInvalidOperation.CreateFmt(SParentRequired, [Name]);
  1977.   Result := Parent.ClientOrigin;
  1978.   Inc(Result.X, FLeft);
  1979.   Inc(Result.Y, FTop);
  1980. end;
  1981.  
  1982. function TControl.ClientToScreen(const Point: TPoint): TPoint;
  1983. var
  1984.   Origin: TPoint;
  1985. begin
  1986.   Origin := ClientOrigin;
  1987.   Result.X := Point.X + Origin.X;
  1988.   Result.Y := Point.Y + Origin.Y;
  1989. end;
  1990.  
  1991. function TControl.ScreenToClient(const Point: TPoint): TPoint;
  1992. var
  1993.   Origin: TPoint;
  1994. begin
  1995.   Origin := ClientOrigin;
  1996.   Result.X := Point.X - Origin.X;
  1997.   Result.Y := Point.Y - Origin.Y;
  1998. end;
  1999.  
  2000. procedure TControl.SendCancelMode(Sender: TControl);
  2001. var
  2002.   Form: TCustomForm;
  2003. begin
  2004.   Form := GetParentForm(Self);
  2005.   if Form <> nil then Form.SendCancelMode(Sender);
  2006. end;
  2007.  
  2008. procedure TControl.Changed;
  2009. begin
  2010.   Perform(CM_CHANGED, 0, Longint(Self));
  2011. end;
  2012.  
  2013. procedure TControl.ChangeScale(M, D: Integer);
  2014. var
  2015.   X, Y, W, H: Integer;
  2016.   Flags: TScalingFlags;
  2017. begin
  2018.   if M <> D then
  2019.   begin
  2020.     if csLoading in ComponentState then
  2021.       Flags := ScalingFlags else
  2022.       Flags := [sfLeft, sfTop, sfWidth, sfHeight, sfFont];
  2023.     if sfLeft in Flags then
  2024.       X := MulDiv(FLeft, M, D) else
  2025.       X := FLeft;
  2026.     if sfTop in Flags then
  2027.       Y := MulDiv(FTop, M, D) else
  2028.       Y := FTop;
  2029.     if (sfWidth in Flags) and not (csFixedWidth in ControlStyle) then
  2030.       W := MulDiv(FLeft + FWidth, M, D) - X else
  2031.       W := FWidth;
  2032.     if (sfHeight in Flags) and not (csFixedHeight in ControlStyle) then
  2033.       H := MulDiv(FTop + FHeight, M, D) - Y else
  2034.       H := FHeight;
  2035.     SetBounds(X, Y, W, H);
  2036.     if not ParentFont and (sfFont in Flags) then
  2037.       Font.Size := MulDiv(Font.Size, M, D);
  2038.   end;
  2039.   FScalingFlags := [];
  2040. end;
  2041.  
  2042. procedure TControl.SetName(const Value: TComponentName);
  2043. var
  2044.   ChangeText: Boolean;
  2045. begin
  2046.   ChangeText := (csSetCaption in ControlStyle) and (Name = Text) and
  2047.     ((Owner = nil) or not (Owner is TControl) or
  2048.     not (csLoading in TControl(Owner).ComponentState));
  2049.   inherited SetName(Value);
  2050.   if ChangeText then Text := Value;
  2051. end;
  2052.  
  2053. procedure TControl.SetClientSize(Value: TPoint);
  2054. var
  2055.   Client: TRect;
  2056. begin
  2057.   Client := GetClientRect;
  2058.   SetBounds(FLeft, FTop, Width - Client.Right + Value.X, Height -
  2059.     Client.Bottom + Value.Y);
  2060. end;
  2061.  
  2062. procedure TControl.SetParent(AParent: TWinControl);
  2063. begin
  2064.   if FParent <> AParent then
  2065.   begin
  2066.     if Parent = Self then
  2067.       raise EInvalidOperation.Create(SControlParentSetToSelf);
  2068.     if FParent <> nil then FParent.RemoveControl(Self);
  2069.     if AParent <> nil then AParent.InsertControl(Self);
  2070.   end;
  2071. end;
  2072.  
  2073. procedure TControl.SetVisible(Value: Boolean);
  2074. begin
  2075.   if FVisible <> Value then
  2076.   begin
  2077.     VisibleChanging;
  2078.     FVisible := Value;
  2079.     Perform(CM_VISIBLECHANGED, 0, 0);
  2080.     RequestAlign;
  2081.   end;
  2082. end;
  2083.  
  2084. procedure TControl.SetEnabled(Value: Boolean);
  2085. begin
  2086.   if FEnabled <> Value then
  2087.   begin
  2088.     FEnabled := Value;
  2089.     Perform(CM_ENABLEDCHANGED, 0, 0);
  2090.   end;
  2091. end;
  2092.  
  2093. function TControl.GetTextLen: Integer;
  2094. begin
  2095.   Result := Perform(WM_GETTEXTLENGTH, 0, 0);
  2096. end;
  2097.  
  2098. function TControl.GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  2099. begin
  2100.   Result := Perform(WM_GETTEXT, BufSize, Longint(Buffer));
  2101. end;
  2102.  
  2103. procedure TControl.SetPopupMenu(Value: TPopupMenu);
  2104. begin
  2105.   FPopupMenu := Value;
  2106.   if Value <> nil then Value.FreeNotification(Self);
  2107. end;
  2108.  
  2109. procedure TControl.SetTextBuf(Buffer: PChar);
  2110. begin
  2111.   Perform(WM_SETTEXT, 0, Longint(Buffer));
  2112.   Perform(CM_TEXTCHANGED, 0, 0);
  2113. end;
  2114.  
  2115. function TControl.GetText: TCaption;
  2116. var
  2117.   Len: Integer;
  2118. begin
  2119.   Len := GetTextLen;
  2120.   SetString(Result, PChar(nil), Len);
  2121.   if Len <> 0 then GetTextBuf(Pointer(Result), Len + 1);
  2122. end;
  2123.  
  2124. procedure TControl.SetText(const Value: TCaption);
  2125. begin
  2126.   if GetText <> Value then SetTextBuf(PChar(Value));
  2127. end;
  2128.  
  2129. procedure TControl.FontChanged(Sender: TObject);
  2130. begin
  2131.   FParentFont := False;
  2132.   if Font.Height <> FFontHeight then
  2133.   begin
  2134.     Include(FScalingFlags, sfFont);
  2135.     FFontHeight := Font.Height;
  2136.   end;
  2137.   Perform(CM_FONTCHANGED, 0, 0);
  2138. end;
  2139.  
  2140. procedure TControl.SetFont(Value: TFont);
  2141. begin
  2142.   FFont.Assign(Value);
  2143. end;
  2144.  
  2145. function TControl.IsFontStored: Boolean;
  2146. begin
  2147.   Result := not ParentFont;
  2148. end;
  2149.  
  2150. function TControl.IsShowHintStored: Boolean;
  2151. begin
  2152.   Result := not ParentShowHint;
  2153. end;
  2154.  
  2155. procedure TControl.SetParentFont(Value: Boolean);
  2156. begin
  2157.   if FParentFont <> Value then
  2158.   begin
  2159.     FParentFont := Value;
  2160.     if FParent <> nil then
  2161.       Perform(CM_PARENTFONTCHANGED, 0, 0)
  2162.     else
  2163.       Perform(CM_SYSFONTCHANGED, 0, 0);
  2164.   end;
  2165. end;
  2166.  
  2167. procedure TControl.SetShowHint(Value: Boolean);
  2168. begin
  2169.   if FShowHint <> Value then
  2170.   begin
  2171.     FShowHint := Value;
  2172.     FParentShowHint := False;
  2173.     Perform(CM_SHOWHINTCHANGED, 0, 0);
  2174.   end;
  2175. end;
  2176.  
  2177. procedure TControl.SetParentShowHint(Value: Boolean);
  2178. begin
  2179.   if FParentShowHint <> Value then
  2180.   begin
  2181.     FParentShowHint := Value;
  2182.     if FParent <> nil then Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  2183.   end;
  2184. end;
  2185.  
  2186. procedure TControl.SetColor(Value: TColor);
  2187. begin
  2188.   if FColor <> Value then
  2189.   begin
  2190.     FColor := Value;
  2191.     FParentColor := False;
  2192.     Perform(CM_COLORCHANGED, 0, 0);
  2193.   end;
  2194. end;
  2195.  
  2196. function TControl.IsColorStored: Boolean;
  2197. begin
  2198.   Result := not ParentColor;
  2199. end;
  2200.  
  2201. procedure TControl.SetParentColor(Value: Boolean);
  2202. begin
  2203.   if FParentColor <> Value then
  2204.   begin
  2205.     FParentColor := Value;
  2206.     if FParent <> nil then Perform(CM_PARENTCOLORCHANGED, 0, 0);
  2207.   end;
  2208. end;
  2209.  
  2210. procedure TControl.SetCursor(Value: TCursor);
  2211. begin
  2212.   if FCursor <> Value then
  2213.   begin
  2214.     FCursor := Value;
  2215.     Perform(CM_CURSORCHANGED, 0, 0);
  2216.   end;
  2217. end;
  2218.  
  2219. function TControl.GetMouseCapture: Boolean;
  2220. begin
  2221.   Result := GetCaptureControl = Self;
  2222. end;
  2223.  
  2224. procedure TControl.SetMouseCapture(Value: Boolean);
  2225. begin
  2226.   if MouseCapture <> Value then
  2227.     if Value then SetCaptureControl(Self) else SetCaptureControl(nil);
  2228. end;
  2229.  
  2230. procedure TControl.BringToFront;
  2231. begin
  2232.   SetZOrder(True);
  2233. end;
  2234.  
  2235. procedure TControl.SendToBack;
  2236. begin
  2237.   SetZOrder(False);
  2238. end;
  2239.  
  2240. procedure TControl.SetZOrderPosition(Position: Integer);
  2241. var
  2242.   I, Count: Integer;
  2243.   ParentForm: TCustomForm;
  2244. begin
  2245.   if FParent <> nil then
  2246.   begin
  2247.     I := FParent.FControls.IndexOf(Self);
  2248.     if I >= 0 then
  2249.     begin
  2250.       Count := FParent.FControls.Count;
  2251.       if Position < 0 then Position := 0;
  2252.       if Position >= Count then Position := Count - 1;
  2253.       if Position <> I then
  2254.       begin
  2255.         FParent.FControls.Delete(I);
  2256.         FParent.FControls.Insert(Position, Self);
  2257.         InvalidateControl(Visible, True);
  2258.         ParentForm := ValidParentForm(Self);
  2259.         if csPalette in ParentForm.ControlState then
  2260.           TControl(ParentForm).PaletteChanged(True);
  2261.       end;
  2262.     end;
  2263.   end;
  2264. end;
  2265.  
  2266. procedure TControl.SetZOrder(TopMost: Boolean);
  2267. begin
  2268.   if FParent <> nil then
  2269.     if TopMost then
  2270.       SetZOrderPosition(FParent.FControls.Count - 1) else
  2271.       SetZOrderPosition(0);
  2272. end;
  2273.  
  2274. function TControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
  2275. begin
  2276.   if Parent = nil then
  2277.     raise EInvalidOperation.CreateFmt(SParentRequired, [Name]);
  2278.   Result := Parent.GetDeviceContext(WindowHandle);
  2279.   SetViewportOrgEx(Result, Left, Top, nil);
  2280.   IntersectClipRect(Result, 0, 0, Width, Height);
  2281. end;
  2282.  
  2283. procedure TControl.InvalidateControl(IsVisible, IsOpaque: Boolean);
  2284. var
  2285.   Rect: TRect;
  2286.  
  2287.   function BackgroundClipped: Boolean;
  2288.   var
  2289.     R: TRect;
  2290.     List: TList;
  2291.     I: Integer;
  2292.     C: TControl;
  2293.   begin
  2294.     Result := True;
  2295.     List := FParent.FControls;
  2296.     I := List.IndexOf(Self);
  2297.     while I > 0 do
  2298.     begin
  2299.       Dec(I);
  2300.       C := List[I];
  2301.       with C do
  2302.         if csOpaque in ControlStyle then
  2303.         begin
  2304.           IntersectRect(R, Rect, BoundsRect);
  2305.           if EqualRect(R, Rect) then Exit;
  2306.         end;
  2307.     end;
  2308.     Result := False;
  2309.   end;
  2310.  
  2311. begin
  2312.   if (IsVisible or (csDesigning in ComponentState) and
  2313.     not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and
  2314.     Parent.HandleAllocated then
  2315.   begin
  2316.     Rect := BoundsRect;
  2317.     InvalidateRect(Parent.Handle, @Rect, not (IsOpaque or
  2318.       (csOpaque in Parent.ControlStyle) or BackgroundClipped));
  2319.   end;
  2320. end;
  2321.  
  2322. procedure TControl.Invalidate;
  2323. begin
  2324.   InvalidateControl(Visible, csOpaque in ControlStyle);
  2325. end;
  2326.  
  2327. procedure TControl.Hide;
  2328. begin
  2329.   Visible := False;
  2330. end;
  2331.  
  2332. procedure TControl.Show;
  2333. begin
  2334.   if Parent <> nil then Parent.ShowControl(Self);
  2335.   if not (csDesigning in ComponentState) or
  2336.     (csNoDesignVisible in ControlStyle) then Visible := True;
  2337. end;
  2338.  
  2339. procedure TControl.Update;
  2340. begin
  2341.   if Parent <> nil then Parent.Update;
  2342. end;
  2343.  
  2344. procedure TControl.Refresh;
  2345. begin
  2346.   Repaint;
  2347. end;
  2348.  
  2349. procedure TControl.Repaint;
  2350. var
  2351.   DC: HDC;
  2352. begin
  2353.   if (Visible or (csDesigning in ComponentState) and
  2354.     not (csNoDesignVisible in ControlStyle)) and (Parent <> nil) and
  2355.     Parent.HandleAllocated then
  2356.     if csOpaque in ControlStyle then
  2357.     begin
  2358.       DC := GetDC(Parent.Handle);
  2359.       try
  2360.         IntersectClipRect(DC, Left, Top, Left + Width, Top + Height);
  2361.         Parent.PaintControls(DC, Self);
  2362.       finally
  2363.         ReleaseDC(Parent.Handle, DC);
  2364.       end;
  2365.     end else
  2366.     begin
  2367.       Invalidate;
  2368.       Update;
  2369.     end;
  2370. end;
  2371.  
  2372. procedure TControl.BeginDrag(Immediate: Boolean);
  2373. var
  2374.   P: TPoint;
  2375. begin
  2376.   if Self is TCustomForm then
  2377.     raise EInvalidOperation.Create(SCannotDragForm);
  2378.   if DragControl = nil then
  2379.   begin
  2380.     DragControl := Self;
  2381.     if csLButtonDown in ControlState then
  2382.     begin
  2383.       GetCursorPos(P);
  2384.       P := ScreenToClient(P);
  2385.       Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P)));
  2386.     end;
  2387.     if DragControl = Self then DragInitControl(Self, Immediate);
  2388.   end;
  2389. end;
  2390.  
  2391. procedure TControl.EndDrag(Drop: Boolean);
  2392. begin
  2393.   if Dragging then DragDone(Drop);
  2394. end;
  2395.  
  2396. procedure TControl.DragCanceled;
  2397. begin
  2398. end;
  2399.  
  2400. function TControl.Dragging: Boolean;
  2401. begin
  2402.   Result := DragControl = Self;
  2403. end;
  2404.  
  2405. procedure TControl.DragOver(Source: TObject; X, Y: Integer;
  2406.   State: TDragState; var Accept: Boolean);
  2407. begin
  2408.   Accept := True;
  2409.   if Assigned(FOnDragOver) then
  2410.     FOnDragOver(Self, Source, X, Y, State, Accept) else
  2411.     Accept := False;
  2412. end;
  2413.  
  2414. procedure TControl.DragDrop(Source: TObject; X, Y: Integer);
  2415. begin
  2416.   if Assigned(FOnDragDrop) then FOnDragDrop(Self, Source, X, Y);
  2417. end;
  2418.  
  2419. procedure TControl.DoStartDrag(var DragObject: TDragObject);
  2420. begin
  2421.   if Assigned(FOnStartDrag) then FOnStartDrag(Self, DragObject);
  2422. end;
  2423.  
  2424. procedure TControl.DoEndDrag(Target: TObject; X, Y: Integer);
  2425. begin
  2426.   if Assigned(FOnEndDrag) then FOnEndDrag(Self, Target, X, Y);
  2427. end;
  2428.  
  2429. procedure TControl.DoDragMsg(var DragMsg: TCMDrag);
  2430. var
  2431.   S: Pointer;
  2432.   Accepts: Boolean;
  2433. begin
  2434.   with DragMsg, DragRec^ do
  2435.   begin
  2436.     S := Source;
  2437.     if TDragObject(S) is TDragControlObject then
  2438.       S := TDragControlObject(S).Control;
  2439.     with ScreenToClient(Pos) do
  2440.       case DragMessage of
  2441.         dmDragEnter, dmDragLeave, dmDragMove:
  2442.          begin
  2443.            DragOver(S, X, Y, TDragState(DragMessage), Accepts);
  2444.            Result := Ord(Accepts);
  2445.          end;
  2446.         dmDragDrop: DragDrop(S, X, Y);
  2447.       end;
  2448.   end;
  2449. end;
  2450.  
  2451. function TControl.Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;
  2452. var
  2453.   Message: TMessage;
  2454. begin
  2455.   Message.Msg := Msg;
  2456.   Message.WParam := WParam;
  2457.   Message.LParam := LParam;
  2458.   Message.Result := 0;
  2459.   if Self <> nil then WindowProc(Message);
  2460.   Result := Message.Result;
  2461. end;
  2462.  
  2463. procedure TControl.UpdateBoundsRect(const R: TRect);
  2464. begin
  2465.   FLeft := R.left;
  2466.   FTop := R.top;
  2467.   FWidth := R.right - R.left;
  2468.   FHeight := R.bottom - R.top;
  2469. end;
  2470.  
  2471. procedure TControl.VisibleChanging;
  2472. begin
  2473. end;
  2474.  
  2475. procedure TControl.WndProc(var Message: TMessage);
  2476. var
  2477.   Form: TCustomForm;
  2478. begin
  2479.   if csDesigning in ComponentState then
  2480.   begin
  2481.     Form := GetParentForm(Self);
  2482.     if (Form <> nil) and (Form.Designer <> nil) and
  2483.       Form.Designer.IsDesignMsg(Self, Message) then Exit;
  2484.   end;
  2485.   if (Message.Msg >= WM_MOUSEFIRST) and (Message.Msg <= WM_MOUSELAST) then
  2486.   begin
  2487.     if not (csDoubleClicks in ControlStyle) then
  2488.       case Message.Msg of
  2489.         WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK, WM_MBUTTONDBLCLK:
  2490.           Dec(Message.Msg, WM_LBUTTONDBLCLK - WM_LBUTTONDOWN);
  2491.       end;
  2492.     case Message.Msg of
  2493.       WM_MOUSEMOVE: Application.HintMouseMessage(Self, Message);
  2494.       WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
  2495.         begin
  2496.           if FDragMode = dmAutomatic then
  2497.           begin
  2498.             BeginDrag(True);
  2499.             Exit;
  2500.           end;
  2501.           Include(FControlState, csLButtonDown);
  2502.         end;
  2503.       WM_LBUTTONUP:
  2504.         Exclude(FControlState, csLButtonDown);
  2505.     end;
  2506.   end;
  2507.   Dispatch(Message);
  2508. end;
  2509.  
  2510. procedure TControl.DefaultHandler(var Message);
  2511. var
  2512.   P: PChar;
  2513. begin
  2514.   with TMessage(Message) do
  2515.     case Msg of
  2516.       WM_GETTEXT:
  2517.         begin
  2518.           if FText <> nil then P := FText else P := '';
  2519.           Result := StrLen(StrLCopy(PChar(LParam), P, WParam - 1));
  2520.         end;
  2521.       WM_GETTEXTLENGTH:
  2522.         if FText = nil then Result := 0 else Result := StrLen(FText);
  2523.       WM_SETTEXT:
  2524.         begin
  2525.           P := StrNew(PChar(LParam));
  2526.           StrDispose(FText);
  2527.           FText := P;
  2528.         end;
  2529.     end;
  2530. end;
  2531.  
  2532. procedure TControl.ReadIsControl(Reader: TReader);
  2533. begin
  2534.   FIsControl := Reader.ReadBoolean;
  2535. end;
  2536.  
  2537. procedure TControl.WriteIsControl(Writer: TWriter);
  2538. begin
  2539.   Writer.WriteBoolean(FIsControl);
  2540. end;
  2541.  
  2542. procedure TControl.DefineProperties(Filer: TFiler);
  2543.  
  2544.   function DoWrite: Boolean;
  2545.   begin
  2546.     if Filer.Ancestor <> nil then
  2547.       Result := TControl(Filer.Ancestor).IsControl <> IsControl else
  2548.       Result := IsControl;
  2549.   end;
  2550.  
  2551. begin
  2552.   { The call to inherited DefinedProperties is omitted since the Left and
  2553.     Top special properties are redefined with real properties }
  2554.   Filer.DefineProperty('IsControl', ReadIsControl, WriteIsControl, DoWrite);
  2555. end;
  2556.  
  2557. procedure TControl.Click;
  2558. begin
  2559.   if Assigned(FOnClick) then FOnClick(Self);
  2560. end;
  2561.  
  2562. procedure TControl.DblClick;
  2563. begin
  2564.   if Assigned(FOnDblClick) then FOnDblClick(Self);
  2565. end;
  2566.  
  2567. procedure TControl.MouseDown(Button: TMouseButton;
  2568.   Shift: TShiftState; X, Y: Integer);
  2569. begin
  2570.   if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);
  2571. end;
  2572.  
  2573. procedure TControl.DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
  2574.   Shift: TShiftState);
  2575. begin
  2576.   if not (csNoStdEvents in ControlStyle) then
  2577.     with Message do
  2578.       MouseDown(Button, KeysToShiftState(Keys) + Shift, XPos, YPos);
  2579. end;
  2580.  
  2581. procedure TControl.WMLButtonDown(var Message: TWMLButtonDown);
  2582. begin
  2583.   SendCancelMode(Self);
  2584.   inherited;
  2585.   if csCaptureMouse in ControlStyle then MouseCapture := True;
  2586.   if csClickEvents in ControlStyle then Include(FControlState, csClicked);
  2587.   DoMouseDown(Message, mbLeft, []);
  2588. end;
  2589.  
  2590. procedure TControl.WMNCLButtonDown(var Message: TWMNCLButtonDown);
  2591. begin
  2592.   SendCancelMode(Self);
  2593.   inherited;
  2594. end;
  2595.  
  2596. procedure TControl.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  2597. begin
  2598.   SendCancelMode(Self);
  2599.   inherited;
  2600.   if csCaptureMouse in ControlStyle then MouseCapture := True;
  2601.   if csClickEvents in ControlStyle then DblClick;
  2602.   DoMouseDown(Message, mbLeft, [ssDouble]);
  2603. end;
  2604.  
  2605. function TControl.GetPopupMenu: TPopupMenu;
  2606. begin
  2607.   Result := FPopupMenu;
  2608. end;
  2609.  
  2610. procedure TControl.CheckMenuPopup(const Pos: TSmallPoint);
  2611. var
  2612.   Control: TControl;
  2613.   PopupMenu: TPopupMenu;
  2614. begin
  2615.   if csDesigning in ComponentState then Exit;
  2616.   Control := Self;
  2617.   while Control <> nil do
  2618.   begin
  2619.     PopupMenu := Control.GetPopupMenu;
  2620.     if (PopupMenu <> nil) and PopupMenu.AutoPopup then
  2621.     begin
  2622.       SendCancelMode(nil);
  2623.       PopupMenu.PopupComponent := Control;
  2624.       with ClientToScreen(SmallPointToPoint(Pos)) do
  2625.         PopupMenu.Popup(X, Y);
  2626.       Exit;
  2627.     end;
  2628.     Control := Control.Parent;
  2629.   end;
  2630. end;
  2631.  
  2632. procedure TControl.WMRButtonDown(var Message: TWMRButtonDown);
  2633. begin
  2634.   inherited;
  2635.   DoMouseDown(Message, mbRight, []);
  2636. end;
  2637.  
  2638. procedure TControl.WMRButtonDblClk(var Message: TWMRButtonDblClk);
  2639. begin
  2640.   inherited;
  2641.   DoMouseDown(Message, mbRight, [ssDouble]);
  2642. end;
  2643.  
  2644. procedure TControl.WMMButtonDown(var Message: TWMMButtonDown);
  2645. begin
  2646.   inherited;
  2647.   DoMouseDown(Message, mbMiddle, []);
  2648. end;
  2649.  
  2650. procedure TControl.WMMButtonDblClk(var Message: TWMMButtonDblClk);
  2651. begin
  2652.   inherited;
  2653.   DoMouseDown(Message, mbMiddle, [ssDouble]);
  2654. end;
  2655.  
  2656. procedure TControl.MouseMove(Shift: TShiftState; X, Y: Integer);
  2657. begin
  2658.   if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X, Y);
  2659. end;
  2660.  
  2661. procedure TControl.WMMouseMove(var Message: TWMMouseMove);
  2662. begin
  2663.   inherited;
  2664.   if not (csNoStdEvents in ControlStyle) then
  2665.     with Message do MouseMove(KeysToShiftState(Keys), XPos, YPos);
  2666. end;
  2667.  
  2668. procedure TControl.MouseUp(Button: TMouseButton;
  2669.   Shift: TShiftState; X, Y: Integer);
  2670. begin
  2671.   if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X, Y);
  2672. end;
  2673.  
  2674. procedure TControl.DoMouseUp(var Message: TWMMouse; Button: TMouseButton);
  2675. begin
  2676.   if not (csNoStdEvents in ControlStyle) then
  2677.     with Message do MouseUp(Button, KeysToShiftState(Keys), XPos, YPos);
  2678. end;
  2679.  
  2680. procedure TControl.WMLButtonUp(var Message: TWMLButtonUp);
  2681. begin
  2682.   inherited;
  2683.   if csCaptureMouse in ControlStyle then MouseCapture := False;
  2684.   if csClicked in ControlState then
  2685.   begin
  2686.     Exclude(FControlState, csClicked);
  2687.     if PtInRect(ClientRect, SmallPointToPoint(Message.Pos)) then Click;
  2688.   end;
  2689.   DoMouseUp(Message, mbLeft);
  2690. end;
  2691.  
  2692. procedure TControl.WMRButtonUp(var Message: TWMRButtonUp);
  2693. begin
  2694.   inherited;
  2695.   DoMouseUp(Message, mbRight);
  2696.   if Message.Result = 0 then CheckMenuPopup(Message.Pos);
  2697. end;
  2698.  
  2699. procedure TControl.WMMButtonUp(var Message: TWMMButtonUp);
  2700. begin
  2701.   inherited;
  2702.   DoMouseUp(Message, mbMiddle);
  2703. end;
  2704.  
  2705. procedure TControl.WMCancelMode(var Message: TWMCancelMode);
  2706. begin
  2707.   inherited;
  2708.   if MouseCapture then
  2709.   begin
  2710.     MouseCapture := False;
  2711.     if csLButtonDown in ControlState then Perform(WM_LBUTTONUP, 0, $FFFFFFFF);
  2712.   end;
  2713. end;
  2714.  
  2715. procedure TControl.CMVisibleChanged(var Message: TMessage);
  2716. begin
  2717.   if not (csDesigning in ComponentState) or
  2718.     (csNoDesignVisible in ControlStyle) then
  2719.     InvalidateControl(True, FVisible and (csOpaque in ControlStyle));
  2720. end;
  2721.  
  2722. procedure TControl.CMEnabledChanged(var Message: TMessage);
  2723. begin
  2724.   Invalidate;
  2725. end;
  2726.  
  2727. procedure TControl.CMFontChanged(var Message: TMessage);
  2728. begin
  2729.   Invalidate;
  2730. end;
  2731.  
  2732. procedure TControl.CMColorChanged(var Message: TMessage);
  2733. begin
  2734.   Invalidate;
  2735. end;
  2736.  
  2737. procedure TControl.CMParentColorChanged(var Message: TMessage);
  2738. begin
  2739.   if FParentColor then
  2740.   begin
  2741.     SetColor(FParent.FColor);
  2742.     FParentColor := True;
  2743.   end;
  2744. end;
  2745.  
  2746. procedure TControl.CMParentShowHintChanged(var Message: TMessage);
  2747. begin
  2748.   if FParentShowHint then
  2749.   begin
  2750.     SetShowHint(FParent.FShowHint);
  2751.     FParentShowHint := True;
  2752.   end;
  2753. end;
  2754.  
  2755. procedure TControl.CMParentFontChanged(var Message: TMessage);
  2756. begin
  2757.   if FParentFont then
  2758.   begin
  2759.     SetFont(FParent.FFont);
  2760.     FParentFont := True;
  2761.   end;
  2762. end;
  2763.  
  2764. procedure TControl.CMSysFontChanged(var Message: TMessage);
  2765. begin
  2766.   if FParentFont then
  2767.   begin
  2768.     SetFont(Screen.IconFont);
  2769.     FParentFont := True;
  2770.   end;
  2771. end;
  2772.  
  2773. procedure TControl.CMHitTest(var Message: TCMHitTest);
  2774. begin
  2775.   Message.Result := 1;
  2776. end;
  2777.  
  2778. procedure TControl.CMMouseEnter(var Message: TMessage);
  2779. begin
  2780.   if FParent <> nil then
  2781.     FParent.Perform(CM_MOUSEENTER, 0, Longint(Self));
  2782. end;
  2783.  
  2784. procedure TControl.CMMouseLeave(var Message: TMessage);
  2785. begin
  2786.   if FParent <> nil then
  2787.     FParent.Perform(CM_MOUSELEAVE, 0, Longint(Self));
  2788. end;
  2789.  
  2790. procedure TControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  2791. begin
  2792.   Message.Result := 0;
  2793. end;
  2794.  
  2795. { TWinControl }
  2796.  
  2797. constructor TWinControl.Create(AOwner: TComponent);
  2798. begin
  2799.   inherited Create(AOwner);
  2800.   FObjectInstance := MakeObjectInstance(MainWndProc);
  2801.   FBrush := TBrush.Create;
  2802.   FBrush.Color := FColor;
  2803.   FParentCtl3D := True;
  2804.   FTabOrder := -1;
  2805.   FImeMode := imDontCare;
  2806.   FImeName := Screen.DefaultIme;
  2807. end;
  2808.  
  2809. constructor TWinControl.CreateParented(ParentWindow: HWnd);
  2810. begin
  2811.   FParentWindow := ParentWindow;
  2812.   Create(nil);
  2813. end;
  2814.  
  2815. destructor TWinControl.Destroy;
  2816. var
  2817.   I: Integer;
  2818.   Instance: TControl;
  2819. begin
  2820.   Destroying;
  2821.   if Parent <> nil then RemoveFocus(True);
  2822.   if FHandle <> 0 then DestroyWindowHandle;
  2823.   I := ControlCount;
  2824.   while I <> 0 do
  2825.   begin
  2826.     Instance := Controls[I - 1];
  2827.     Remove(Instance);
  2828.     Instance.Destroy;
  2829.     I := ControlCount;
  2830.   end;
  2831.   FBrush.Free;
  2832.   if FObjectInstance <> nil then FreeObjectInstance(FObjectInstance);
  2833.   inherited Destroy;
  2834. end;
  2835.  
  2836. procedure TWinControl.FixupTabList;
  2837. var
  2838.   Count, I, J: Integer;
  2839.   List: TList;
  2840.   Control: TWinControl;
  2841. begin
  2842.   if FWinControls <> nil then
  2843.   begin
  2844.     List := TList.Create;
  2845.     try
  2846.       Count := FWinControls.Count;
  2847.       List.Count := Count;
  2848.       for I := 0 to Count - 1 do
  2849.       begin
  2850.         Control := FWinControls[I];
  2851.         J := Control.FTabOrder;
  2852.         if (J >= 0) and (J < Count) then List[J] := Control;
  2853.       end;
  2854.       for I := 0 to Count - 1 do
  2855.       begin
  2856.         Control := List[I];
  2857.         if Control <> nil then Control.UpdateTabOrder(I);
  2858.       end;
  2859.     finally
  2860.       List.Free;
  2861.     end;
  2862.   end;
  2863. end;
  2864.  
  2865. procedure TWinControl.ReadState(Reader: TReader);
  2866. begin
  2867.   DisableAlign;
  2868.   try
  2869.     inherited ReadState(Reader);
  2870.   finally
  2871.     EnableAlign;
  2872.   end;
  2873.   FixupTabList;
  2874.   if FParent <> nil then Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  2875.   UpdateControlState;
  2876. end;
  2877.  
  2878. procedure TWinControl.AlignControls(AControl: TControl; var Rect: TRect);
  2879. var
  2880.   AlignList: TList;
  2881.  
  2882.   function InsertBefore(C1, C2: TControl; AAlign: TAlign): Boolean;
  2883.   begin
  2884.     Result := False;
  2885.     case AAlign of
  2886.       alTop: Result := C1.Top < C2.Top;
  2887.       alBottom: Result := (C1.Top + C1.Height) > (C2.Top + C2.Height);
  2888.       alLeft: Result := C1.Left < C2.Left;
  2889.       alRight: Result := (C1.Left + C1.Width) > (C2.Left + C2.Width);
  2890.     end;
  2891.   end;
  2892.  
  2893.   procedure DoPosition(Control: TControl; AAlign: TAlign);
  2894.  
  2895.     function NonNeg(Value, Default: Integer): Integer;
  2896.     begin
  2897.       if Value < 0 then
  2898.         Result := Default else
  2899.         Result := Value;
  2900.     end;
  2901.  
  2902.   begin
  2903.     with Rect do
  2904.       case AAlign of
  2905.         alTop: Inc(Top, Control.Height);
  2906.         alBottom: Dec(Bottom, Control.Height);
  2907.         alLeft: Inc(Left, Control.Width);
  2908.         alRight: Dec(Right, Control.Width);
  2909.       end;
  2910.     with Rect do
  2911.       case AAlign of
  2912.         alTop: Control.SetBounds(Left, Top - Control.Height,
  2913.           NonNeg(Right - Left, Control.Width), Control.Height);
  2914.         alBottom: Control.SetBounds(Left, Bottom,
  2915.           NonNeg(Right - Left, Control.Width), Control.Height);
  2916.         alLeft: Control.SetBounds(Left - Control.Width, Top, Control.Width,
  2917.           NonNeg(Bottom - Top, Control.Height));
  2918.         alRight: Control.SetBounds(Right, Top, Control.Width,
  2919.           NonNeg(Bottom - Top, Control.Height));
  2920.         alClient: if not IsRectEmpty(Rect) then Control.SetBoundsRect(Rect);
  2921.       end;
  2922.   end;
  2923.  
  2924.   procedure DoAlign(AAlign: TAlign);
  2925.   var
  2926.     I, J: Integer;
  2927.     Control: TControl;
  2928.   begin
  2929.     AlignList.Clear;
  2930.     if (AControl <> nil) and (AControl.Visible or
  2931.       (csDesigning in AControl.ComponentState) and
  2932.       not (csNoDesignVisible in AControl.ControlStyle)) and
  2933.       (AControl.Align = AAlign) then
  2934.       AlignList.Add(AControl);
  2935.     for I := 0 to ControlCount - 1 do
  2936.     begin
  2937.       Control := Controls[I];
  2938.       if (Control.Align = AAlign) and (Control.Visible or
  2939.         (csDesigning in Control.ComponentState) and
  2940.         not (csNoDesignVisible in Control.ControlStyle)) then
  2941.       begin
  2942.         if Control = AControl then Continue;
  2943.         J := 0;
  2944.         while (J < AlignList.Count) and not InsertBefore(Control,
  2945.           TControl(AlignList[J]), AAlign) do Inc(J);
  2946.         AlignList.Insert(J, Control);
  2947.       end;
  2948.     end;
  2949.     for I := 0 to AlignList.Count - 1 do
  2950.       DoPosition(TControl(AlignList[I]), AAlign);
  2951.   end;
  2952.  
  2953.   function AlignWork: Boolean;
  2954.   var
  2955.     I: Integer;
  2956.   begin
  2957.     Result := True;
  2958.     for I := ControlCount - 1 downto 0 do
  2959.       if Controls[I].Align <> alNone then Exit;
  2960.     Result := False;
  2961.   end;
  2962.  
  2963. begin
  2964.   if not AlignWork then Exit; { No work to do }
  2965.   AlignList := TList.Create;
  2966.   try
  2967.     DoAlign(alTop);
  2968.     DoAlign(alBottom);
  2969.     DoAlign(alLeft);
  2970.     DoAlign(alRight);
  2971.     DoAlign(alClient);
  2972.   finally
  2973.     AlignList.Free;
  2974.   end;
  2975. end;
  2976.  
  2977. procedure TWinControl.AlignControl(AControl: TControl);
  2978. var
  2979.   Rect: TRect;
  2980. begin
  2981.   if not HandleAllocated then Exit;
  2982.   if FAlignLevel <> 0 then
  2983.     Include(FControlState, csAlignmentNeeded)
  2984.   else
  2985.   begin
  2986.     DisableAlign;
  2987.     try
  2988.       Rect := GetClientRect;
  2989.       AlignControls(AControl, Rect);
  2990.     finally
  2991.       Exclude(FControlState, csAlignmentNeeded);
  2992.       EnableAlign;
  2993.     end;
  2994.   end;
  2995. end;
  2996.  
  2997. procedure TWinControl.DisableAlign;
  2998. begin
  2999.   Inc(FAlignLevel);
  3000. end;
  3001.  
  3002. procedure TWinControl.EnableAlign;
  3003. begin
  3004.   Dec(FAlignLevel);
  3005.   if (FAlignLevel = 0) and (csAlignmentNeeded in ControlState) then Realign;
  3006. end;
  3007.  
  3008. procedure TWinControl.Realign;
  3009. begin
  3010.   AlignControl(nil);
  3011. end;
  3012.  
  3013. function TWinControl.ContainsControl(Control: TControl): Boolean;
  3014. begin
  3015.   while (Control <> nil) and (Control <> Self) do Control := Control.Parent;
  3016.   Result := Control <> nil;
  3017. end;
  3018.  
  3019. procedure TWinControl.RemoveFocus(Removing: Boolean);
  3020. var
  3021.   Form: TCustomForm;
  3022. begin
  3023.   Form := GetParentForm(Self);
  3024.   if Form <> nil then Form.DefocusControl(Self, Removing);
  3025. end;
  3026.  
  3027. procedure TWinControl.Insert(AControl: TControl);
  3028. begin
  3029.   if AControl <> nil then
  3030.   begin
  3031.     if AControl is TWinControl then
  3032.     begin
  3033.       ListAdd(FWinControls, AControl);
  3034.       ListAdd(FTabList, AControl);
  3035.     end else
  3036.       ListAdd(FControls, AControl);
  3037.     AControl.FParent := Self;
  3038.   end;
  3039. end;
  3040.  
  3041. procedure TWinControl.Remove(AControl: TControl);
  3042. begin
  3043.   if AControl is TWinControl then
  3044.   begin
  3045.     ListRemove(FTabList, AControl);
  3046.     ListRemove(FWinControls, AControl);
  3047.   end else
  3048.     ListRemove(FControls, AControl);
  3049.   AControl.FParent := nil;
  3050. end;
  3051.  
  3052. procedure TWinControl.InsertControl(AControl: TControl);
  3053. begin
  3054.   AControl.ValidateContainer(Self);
  3055.   Perform(CM_CONTROLLISTCHANGE, Integer(AControl), Integer(True));
  3056.   Insert(AControl);
  3057.   if not (csReadingState in AControl.ControlState) then
  3058.   begin
  3059.     AControl.Perform(CM_PARENTCOLORCHANGED, 0, 0);
  3060.     AControl.Perform(CM_PARENTFONTCHANGED, 0, 0);
  3061.     AControl.Perform(CM_PARENTSHOWHINTCHANGED, 0, 0);
  3062.     if AControl is TWinControl then
  3063.     begin
  3064.       AControl.Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  3065.       UpdateControlState;
  3066.     end else
  3067.       if HandleAllocated then AControl.Invalidate;
  3068.     AlignControl(AControl);
  3069.   end;
  3070.   Perform(CM_CONTROLCHANGE, Integer(AControl), Integer(True));
  3071. end;
  3072.  
  3073. procedure TWinControl.RemoveControl(AControl: TControl);
  3074. begin
  3075.   Perform(CM_CONTROLCHANGE, Integer(AControl), Integer(False));
  3076.   if AControl is TWinControl then
  3077.     with TWinControl(AControl) do
  3078.     begin
  3079.       RemoveFocus(True);
  3080.       DestroyHandle;
  3081.     end
  3082.   else
  3083.     if HandleAllocated then
  3084.       AControl.InvalidateControl(AControl.Visible, False);
  3085.   Remove(AControl);
  3086.   Perform(CM_CONTROLLISTCHANGE, Integer(AControl), Integer(False));
  3087.   Realign;
  3088. end;
  3089.  
  3090. function TWinControl.GetControl(Index: Integer): TControl;
  3091. var
  3092.   N: Integer;
  3093. begin
  3094.   if FControls <> nil then N := FControls.Count else N := 0;
  3095.   if Index < N then
  3096.     Result := FControls[Index] else
  3097.     Result := FWinControls[Index - N];
  3098. end;
  3099.  
  3100. function TWinControl.GetControlCount: Integer;
  3101. begin
  3102.   Result := 0;
  3103.   if FControls <> nil then Inc(Result, FControls.Count);
  3104.   if FWinControls <> nil then Inc(Result, FWinControls.Count);
  3105. end;
  3106.  
  3107. procedure TWinControl.Broadcast(var Message);
  3108. var
  3109.   I: Integer;
  3110. begin
  3111.   for I := 0 to ControlCount - 1 do
  3112.   begin
  3113.     Controls[I].WindowProc(TMessage(Message));
  3114.     if TMessage(Message).Result <> 0 then Exit;
  3115.   end;
  3116. end;
  3117.  
  3118. procedure TWinControl.NotifyControls(Msg: Word);
  3119. var
  3120.   Message: TMessage;
  3121. begin
  3122.   Message.Msg := Msg;
  3123.   Message.WParam := 0;
  3124.   Message.LParam := 0;
  3125.   Message.Result := 0;
  3126.   Broadcast(Message);
  3127. end;
  3128.  
  3129. procedure TWinControl.CreateSubClass(var Params: TCreateParams;
  3130.   ControlClassName: PChar);
  3131. const
  3132.   CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS;
  3133.   CS_ON = CS_VREDRAW or CS_HREDRAW;
  3134. var
  3135.   SaveInstance: THandle;
  3136. begin
  3137.   if ControlClassName <> nil then
  3138.     with Params do
  3139.     begin
  3140.       SaveInstance := WindowClass.hInstance;
  3141.       if not GetClassInfo(HInstance, ControlClassName, WindowClass) then
  3142.         GetClassInfo(0, ControlClassName, WindowClass);
  3143.       WindowClass.hInstance := SaveInstance;
  3144.       WindowClass.style := WindowClass.style and not CS_OFF or CS_ON;
  3145.     end;
  3146. end;
  3147.  
  3148. procedure TWinControl.CreateParams(var Params: TCreateParams);
  3149. begin
  3150.   FillChar(Params, SizeOf(Params), 0);
  3151.   with Params do
  3152.   begin
  3153.     Caption := FText;
  3154.     Style := WS_CHILD or WS_CLIPSIBLINGS;
  3155.     if csAcceptsControls in ControlStyle then
  3156.     begin
  3157.       Style := Style or WS_CLIPCHILDREN;
  3158.       ExStyle := ExStyle or WS_EX_CONTROLPARENT;
  3159.     end;
  3160.     if not (csDesigning in ComponentState) and not FEnabled then
  3161.       Style := Style or WS_DISABLED;
  3162.     if FTabStop then Style := Style or WS_TABSTOP;
  3163.     X := FLeft;
  3164.     Y := FTop;
  3165.     Width := FWidth;
  3166.     Height := FHeight;
  3167.     if Parent <> nil then
  3168.       WndParent := Parent.GetHandle else
  3169.       WndParent := FParentWindow;
  3170.     WindowClass.style := CS_VREDRAW + CS_HREDRAW + CS_DBLCLKS;
  3171.     WindowClass.lpfnWndProc := @DefWindowProc;
  3172.     WindowClass.hCursor := LoadCursor(0, IDC_ARROW);
  3173.     WindowClass.hbrBackground := 0;
  3174.     WindowClass.hInstance := HInstance;
  3175.     StrPCopy(WinClassName, ClassName);
  3176.   end;
  3177. end;
  3178.  
  3179. procedure TWinControl.CreateWnd;
  3180. var
  3181.   Params: TCreateParams;
  3182.   TempClass: TWndClass;
  3183.   ClassRegistered: Boolean;
  3184. begin
  3185.   CreateParams(Params);
  3186.   with Params do
  3187.   begin
  3188.     if (WndParent = 0) and (Style and WS_CHILD <> 0) then
  3189.       raise EInvalidOperation.CreateFmt(SParentRequired, [Name]);
  3190.     FDefWndProc := WindowClass.lpfnWndProc;
  3191.     ClassRegistered := GetClassInfo(WindowClass.hInstance, WinClassName, TempClass);
  3192.     if not ClassRegistered or (TempClass.lpfnWndProc <> @InitWndProc) then
  3193.     begin
  3194.       if ClassRegistered then Windows.UnregisterClass(WinClassName,
  3195.         WindowClass.hInstance);
  3196.       WindowClass.lpfnWndProc := @InitWndProc;
  3197.       WindowClass.lpszClassName := WinClassName;
  3198.       if Windows.RegisterClass(WindowClass) = 0 then RaiseLastWin32Error;
  3199.     end;
  3200.     CreationControl := Self;
  3201.     CreateWindowHandle(Params);
  3202.     if FHandle = 0 then RaiseLastWin32Error;
  3203.   end;
  3204.   StrDispose(FText);
  3205.   FText := nil;
  3206.   UpdateBounds;
  3207.   Perform(WM_SETFONT, FFont.Handle, 1);
  3208. end;
  3209.  
  3210. procedure TWinControl.CreateWindowHandle(const Params: TCreateParams);
  3211. begin
  3212.   with Params do
  3213.     FHandle := CreateWindowEx(ExStyle, WinClassName, Caption, Style,
  3214.       X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param);
  3215. end;
  3216.  
  3217. procedure TWinControl.DestroyWnd;
  3218. var
  3219.   Len: Integer;
  3220. begin
  3221.   Len := GetTextLen;
  3222.   if Len < 1 then FText := StrNew('') else
  3223.   begin
  3224.     FText := StrAlloc(Len + 1);
  3225.     GetTextBuf(FText, StrBufSize(FText));
  3226.   end;
  3227.   FreeDeviceContexts;
  3228.   DestroyWindowHandle;
  3229. end;
  3230.  
  3231. procedure TWinControl.DestroyWindowHandle;
  3232. begin
  3233.   Windows.DestroyWindow(FHandle);
  3234. end;
  3235.  
  3236. function TWinControl.PrecedingWindow(Control: TWinControl): HWnd;
  3237. var
  3238.   I: Integer;
  3239. begin
  3240.   for I := FWinControls.IndexOf(Control) + 1 to FWinControls.Count - 1 do
  3241.   begin
  3242.     Result := TWinControl(FWinControls[I]).FHandle;
  3243.     if Result <> 0 then Exit;
  3244.   end;
  3245.   Result := HWND_TOP;
  3246. end;
  3247.  
  3248. procedure TWinControl.CreateHandle;
  3249. begin
  3250.   if FHandle = 0 then
  3251.   begin
  3252.     CreateWnd;
  3253.     SetProp(FHandle, MakeIntAtom(ControlAtom), THandle(Self));
  3254.     SetProp(FHandle, MakeIntAtom(WindowAtom), THandle(Self));
  3255.     if Parent <> nil then
  3256.       SetWindowPos(FHandle, Parent.PrecedingWindow(Self), 0, 0, 0, 0,
  3257.         SWP_NOMOVE + SWP_NOSIZE + SWP_NOACTIVATE);
  3258.   end;
  3259. end;
  3260.  
  3261. procedure TWinControl.DestroyHandle;
  3262. var
  3263.   I: Integer;
  3264. begin
  3265.   if FHandle <> 0 then
  3266.   begin
  3267.     if FWinControls <> nil then
  3268.       for I := 0 to FWinControls.Count - 1 do
  3269.         TWinControl(FWinControls[I]).DestroyHandle;
  3270.     DestroyWnd;
  3271.   end;
  3272. end;
  3273.  
  3274. procedure TWinControl.RecreateWnd;
  3275. begin
  3276.   if FHandle <> 0 then Perform(CM_RECREATEWND, 0, 0);
  3277. end;
  3278.  
  3279. procedure TWinControl.CMRecreateWnd(var Message: TMessage);
  3280. var
  3281.   WasFocused: Boolean;
  3282. begin
  3283.   WasFocused := Focused;
  3284.   DestroyHandle;
  3285.   UpdateControlState;
  3286.   if WasFocused and (FHandle <> 0) then Windows.SetFocus(FHandle);
  3287. end;
  3288.  
  3289. procedure TWinControl.UpdateShowing;
  3290. var
  3291.   ShowControl: Boolean;
  3292.   I: Integer;
  3293. begin
  3294.   ShowControl := (FVisible or (csDesigning in ComponentState) and
  3295.     not (csNoDesignVisible in ControlStyle)) and
  3296.     not (csReadingState in ControlState);
  3297.   if ShowControl then
  3298.   begin
  3299.     if FHandle = 0 then CreateHandle;
  3300.     if FWinControls <> nil then
  3301.       for I := 0 to FWinControls.Count - 1 do
  3302.         TWinControl(FWinControls[I]).UpdateShowing;
  3303.   end;
  3304.   if FHandle <> 0 then
  3305.     if FShowing <> ShowControl then
  3306.     begin
  3307.       FShowing := ShowControl;
  3308.       try
  3309.         Perform(CM_SHOWINGCHANGED, 0, 0);
  3310.       except
  3311.         FShowing := not ShowControl;
  3312.         raise;
  3313.       end;
  3314.     end;
  3315. end;
  3316.  
  3317. procedure TWinControl.UpdateControlState;
  3318. var
  3319.   Control: TWinControl;
  3320. begin
  3321.   Control := Self;
  3322.   while Control.Parent <> nil do
  3323.   begin
  3324.     Control := Control.Parent;
  3325.     if not Control.Showing then Exit;
  3326.   end;
  3327.   if (Control is TCustomForm) or (Control.FParentWindow <> 0) then UpdateShowing;
  3328. end;
  3329.  
  3330. procedure TWinControl.SetParentWindow(Value: HWnd);
  3331. begin
  3332.   if (FParent = nil) and (FParentWindow <> Value) then
  3333.     if (FHandle <> 0) and (FParentWindow <> 0) and (Value <> 0) then
  3334.     begin
  3335.       FParentWindow := Value;
  3336.       Windows.SetParent(FHandle, Value);
  3337.     end else
  3338.     begin
  3339.       DestroyHandle;
  3340.       FParentWindow := Value;
  3341.       UpdateControlState;
  3342.     end;
  3343. end;
  3344.  
  3345. procedure TWinControl.MainWndProc(var Message: TMessage);
  3346. begin
  3347.   try
  3348.     try
  3349.       WindowProc(Message);
  3350.     finally
  3351.       FreeDeviceContexts;
  3352.       FreeMemoryContexts;
  3353.     end;
  3354.   except
  3355.     Application.HandleException(Self);
  3356.   end;
  3357. end;
  3358.  
  3359. function TWinControl.ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl;
  3360. var
  3361.   I: Integer;
  3362.   P: TPoint;
  3363. begin
  3364.   if FControls <> nil then
  3365.     for I := FControls.Count - 1 downto 0 do
  3366.     begin
  3367.       Result := FControls[I];
  3368.       with Result do
  3369.       begin
  3370.         P := Point(Pos.X - Left, Pos.Y - Top);
  3371.         if PtInRect(ClientRect, P) and
  3372.           ((csDesigning in ComponentState) and (Visible or
  3373.           not (csNoDesignVisible in ControlStyle)) or
  3374.           (Visible and (Enabled or AllowDisabled) and
  3375.           (Perform(CM_HITTEST, 0, Longint(PointToSmallPoint(P))) <> 0))) then
  3376.           Exit;
  3377.       end;
  3378.     end;
  3379.   Result := nil;
  3380. end;
  3381.  
  3382. function TWinControl.IsControlMouseMsg(var Message: TWMMouse): Boolean;
  3383. var
  3384.   Control: TControl;
  3385.   P: TPoint;
  3386. begin
  3387.   if GetCapture = Handle then
  3388.   begin
  3389.     Control := nil;
  3390.     if (CaptureControl <> nil) and (CaptureControl.Parent = Self) then
  3391.       Control := CaptureControl;
  3392.   end else
  3393.     Control := ControlAtPos(SmallPointToPoint(Message.Pos), False);
  3394.   Result := False;
  3395.   if Control <> nil then
  3396.   begin
  3397.     P.X := Message.XPos - Control.Left;
  3398.     P.Y := Message.YPos - Control.Top;
  3399.     Control.Perform(Message.Msg, Message.Keys, Longint(PointToSmallPoint(P)));
  3400.     Result := True;
  3401.   end;
  3402. end;
  3403.  
  3404. procedure TWinControl.WndProc(var Message: TMessage);
  3405. var
  3406.   Form: TCustomForm;
  3407. begin
  3408.   case Message.Msg of
  3409.     WM_SETFOCUS:
  3410.       begin
  3411.         Form := GetParentForm(Self);
  3412.         if (Form <> nil) and not Form.SetFocusedControl(Self) then Exit;
  3413.       end;
  3414.     WM_KILLFOCUS:
  3415.       if csFocusing in ControlState then Exit;
  3416.     WM_NCHITTEST:
  3417.       begin
  3418.         inherited WndProc(Message);
  3419.         if (Message.Result = HTTRANSPARENT) and (ControlAtPos(ScreenToClient(
  3420.           SmallPointToPoint(TWMNCHitTest(Message).Pos)), False) <> nil) then
  3421.           Message.Result := HTCLIENT;
  3422.         Exit;
  3423.       end;
  3424.     WM_MOUSEFIRST..WM_MOUSELAST:
  3425.       if IsControlMouseMsg(TWMMouse(Message)) then Exit;
  3426.     WM_KEYFIRST..WM_KEYLAST:
  3427.       if Dragging then Exit;
  3428.     WM_CANCELMODE:
  3429.       if (GetCapture = Handle) and (CaptureControl <> nil) and
  3430.         (CaptureControl.Parent = Self) then
  3431.         CaptureControl.Perform(WM_CANCELMODE, 0, 0);
  3432.   end;
  3433.   inherited WndProc(Message);
  3434. end;
  3435.  
  3436. procedure TWinControl.DefaultHandler(var Message);
  3437. begin
  3438.   if FHandle <> 0 then
  3439.     with TMessage(Message) do
  3440.       case Msg of
  3441.         WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
  3442.           Result := SendMessage(LParam, CN_BASE + Msg, WParam, LParam);
  3443.         CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
  3444.           begin
  3445.             SetTextColor(WParam, ColorToRGB(FFont.Color));
  3446.             SetBkColor(WParam, ColorToRGB(FBrush.Color));
  3447.             Result := FBrush.Handle;
  3448.           end;
  3449.       else
  3450.         Result := CallWindowProc(FDefWndProc, FHandle, Msg, WParam, LParam);
  3451.       end
  3452.   else
  3453.     inherited DefaultHandler(Message);
  3454. end;
  3455.  
  3456. function DoControlMsg(ControlHandle: HWnd; var Message): Boolean;
  3457. var
  3458.   Control: TWinControl;
  3459. begin
  3460.   DoControlMsg := False;
  3461.   Control := FindControl(ControlHandle);
  3462.   if Control <> nil then
  3463.     with TMessage(Message) do
  3464.     begin
  3465.       Result := Control.Perform(Msg + CN_BASE, WParam, LParam);
  3466.       DoControlMsg := True;
  3467.     end;
  3468. end;
  3469.  
  3470. procedure TWinControl.PaintHandler(var Message: TWMPaint);
  3471. var
  3472.   I, Clip, SaveIndex: Integer;
  3473.   DC: HDC;
  3474.   PS: TPaintStruct;
  3475. begin
  3476.   DC := Message.DC;
  3477.   if DC = 0 then DC := BeginPaint(Handle, PS);
  3478.   try
  3479.     if FControls = nil then PaintWindow(DC) else
  3480.     begin
  3481.       SaveIndex := SaveDC(DC);
  3482.       Clip := SimpleRegion;
  3483.       for I := 0 to FControls.Count - 1 do
  3484.         with TControl(FControls[I]) do
  3485.           if (Visible or (csDesigning in ComponentState) and
  3486.             not (csNoDesignVisible in ControlStyle)) and
  3487.             (csOpaque in ControlStyle) then
  3488.           begin
  3489.             Clip := ExcludeClipRect(DC, Left, Top, Left + Width, Top + Height);
  3490.             if Clip = NullRegion then Break;
  3491.           end;
  3492.       if Clip <> NullRegion then PaintWindow(DC);
  3493.       RestoreDC(DC, SaveIndex);
  3494.     end;
  3495.     PaintControls(DC, nil);
  3496.   finally
  3497.     if Message.DC = 0 then EndPaint(Handle, PS);
  3498.   end;
  3499. end;
  3500.  
  3501. procedure TWinControl.PaintWindow(DC: HDC);
  3502. var
  3503.   Message: TMessage;
  3504. begin
  3505.   Message.Msg := WM_PAINT;
  3506.   Message.WParam := DC;
  3507.   Message.LParam := 0;
  3508.   Message.Result := 0;
  3509.   DefaultHandler(Message);
  3510. end;
  3511.  
  3512. procedure TWinControl.PaintControls(DC: HDC; First: TControl);
  3513. var
  3514.   I, Count, SaveIndex: Integer;
  3515.   FrameBrush: HBRUSH;
  3516. begin
  3517.   if FControls <> nil then
  3518.   begin
  3519.     I := 0;
  3520.     if First <> nil then
  3521.     begin
  3522.       I := FControls.IndexOf(First);
  3523.       if I < 0 then I := 0;
  3524.     end;
  3525.     Count := FControls.Count;
  3526.     while I < Count do
  3527.     begin
  3528.       with TControl(FControls[I]) do
  3529.         if (Visible or (csDesigning in ComponentState) and
  3530.           not (csNoDesignVisible in ControlStyle)) and
  3531.           RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
  3532.         begin
  3533.           if csPaintCopy in Self.ControlState then
  3534.             Include(FControlState, csPaintCopy);
  3535.           SaveIndex := SaveDC(DC);
  3536.           MoveWindowOrg(DC, Left, Top);
  3537.           IntersectClipRect(DC, 0, 0, Width, Height);
  3538.           Perform(WM_PAINT, DC, 0);
  3539.           RestoreDC(DC, SaveIndex);
  3540.           Exclude(FControlState, csPaintCopy);
  3541.         end;
  3542.       Inc(I);
  3543.     end;
  3544.   end;
  3545.   if FWinControls <> nil then
  3546.     for I := 0 to FWinControls.Count - 1 do
  3547.       with TWinControl(FWinControls[I]) do
  3548.         if FCtl3D and (csFramed in ControlStyle) and
  3549.           (Visible or (csDesigning in ComponentState) and
  3550.           not (csNoDesignVisible in ControlStyle)) then
  3551.         begin
  3552.           FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
  3553.           FrameRect(DC, Rect(Left - 1, Top - 1, Left + Width, Top + Height),
  3554.             FrameBrush);
  3555.           DeleteObject(FrameBrush);
  3556.           FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
  3557.           FrameRect(DC, Rect(Left, Top, Left + Width + 1, Top + Height + 1),
  3558.             FrameBrush);
  3559.           DeleteObject(FrameBrush);
  3560.         end;
  3561. end;
  3562.  
  3563. procedure TWinControl.PaintTo(DC: HDC; X, Y: Integer);
  3564. var
  3565.   I, EdgeFlags, BorderFlags, SaveIndex: Integer;
  3566.   R: TRect;
  3567. begin
  3568.   Include(FControlState, csPaintCopy);
  3569.   SaveIndex := SaveDC(DC);
  3570.   MoveWindowOrg(DC, X, Y);
  3571.   IntersectClipRect(DC, 0, 0, Width, Height);
  3572.   BorderFlags := 0;
  3573.   EdgeFlags := 0;
  3574.   if GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_CLIENTEDGE <> 0 then
  3575.   begin
  3576.     EdgeFlags := EDGE_SUNKEN;
  3577.     BorderFlags := BF_RECT or BF_ADJUST
  3578.   end else
  3579.   if GetWindowLong(Handle, GWL_STYLE) and WS_BORDER <> 0 then
  3580.   begin
  3581.     EdgeFlags := BDR_OUTER;
  3582.     BorderFlags := BF_RECT or BF_ADJUST or BF_MONO;
  3583.   end;
  3584.   if BorderFlags <> 0 then
  3585.   begin
  3586.     SetRect(R, 0, 0, Width, Height);
  3587.     DrawEdge(DC, R, EdgeFlags, BorderFlags);
  3588.     MoveWindowOrg(DC, R.Left, R.Top);
  3589.     IntersectClipRect(DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);
  3590.   end;
  3591.   Perform(WM_ERASEBKGND, DC, 0);
  3592.   Perform(WM_PAINT, DC, 0);
  3593.   if FWinControls <> nil then
  3594.     for I := 0 to FWinControls.Count - 1 do
  3595.       with TWinControl(FWinControls[I]) do
  3596.         if Visible then PaintTo(DC, Left, Top);
  3597.   RestoreDC(DC, SaveIndex);
  3598.   Exclude(FControlState, csPaintCopy);
  3599. end;
  3600.  
  3601. procedure TWinControl.WMPaint(var Message: TWMPaint);
  3602. var
  3603.   DC, MemDC: HDC;
  3604.   MemBitmap, OldBitmap: HBITMAP;
  3605.   PS: TPaintStruct;
  3606. begin
  3607.   if not FDoubleBuffered or (Message.DC <> 0) then
  3608.     if ControlCount = 0 then inherited else PaintHandler(Message)
  3609.   else
  3610.   begin
  3611.     DC := GetDC(0);
  3612.     MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom);
  3613.     ReleaseDC(0, DC);
  3614.     MemDC := CreateCompatibleDC(0);
  3615.     OldBitmap := SelectObject(MemDC, MemBitmap);
  3616.     try
  3617.       DC := BeginPaint(Handle, PS);
  3618.       Perform(WM_ERASEBKGND, MemDC, MemDC);
  3619.       Message.DC := MemDC;
  3620.       WMPaint(Message);
  3621.       Message.DC := 0;
  3622.       BitBlt(DC, 0, 0, ClientRect.Right, ClientRect.Bottom, MemDC, 0, 0, SRCCOPY);
  3623.       EndPaint(Handle, PS);
  3624.     finally
  3625.       SelectObject(MemDC, OldBitmap);
  3626.       DeleteDC(MemDC);
  3627.       DeleteObject(MemBitmap);
  3628.     end;
  3629.   end;
  3630. end;
  3631.  
  3632. procedure TWinControl.WMCommand(var Message: TWMCommand);
  3633. begin
  3634.   if not DoControlMsg(Message.Ctl, Message) then inherited;
  3635. end;
  3636.  
  3637. procedure TWinControl.WMNotify(var Message: TWMNotify);
  3638. begin
  3639.   if not DoControlMsg(Message.NMHdr^.hWndFrom, Message) then inherited;
  3640. end;
  3641.  
  3642. procedure TWinControl.WMSysColorChange(var Message: TWMSysColorChange);
  3643. begin
  3644.   Graphics.PaletteChanged;
  3645.   Perform(CM_SYSCOLORCHANGE, 0, 0);
  3646. end;
  3647.  
  3648. procedure TWinControl.WMWinIniChange(var Message: TMessage);
  3649. begin
  3650.   Perform(CM_WININICHANGE, Message.wParam, Message.lParam);
  3651. end;
  3652.  
  3653. procedure TWinControl.WMFontChange(var Message: TMessage);
  3654. begin
  3655.   Perform(CM_FONTCHANGE, 0, 0);
  3656. end;
  3657.  
  3658. procedure TWinControl.WMTimeChange(var Message: TMessage);
  3659. begin
  3660.   Perform(CM_TIMECHANGE, 0, 0);
  3661. end;
  3662.  
  3663. procedure TWinControl.WMHScroll(var Message: TWMHScroll);
  3664. begin
  3665.   if not DoControlMsg(Message.ScrollBar, Message) then inherited;
  3666. end;
  3667.  
  3668. procedure TWinControl.WMVScroll(var Message: TWMVScroll);
  3669. begin
  3670.   if not DoControlMsg(Message.ScrollBar, Message) then inherited;
  3671. end;
  3672.  
  3673. procedure TWinControl.WMCompareItem(var Message: TWMCompareItem);
  3674. begin
  3675.   if not DoControlMsg(Message.CompareItemStruct^.CtlID, Message) then inherited;
  3676. end;
  3677.  
  3678. procedure TWinControl.WMDeleteItem(var Message: TWMDeleteItem);
  3679. begin
  3680.   if not DoControlMsg(Message.DeleteItemStruct^.CtlID, Message) then inherited;
  3681. end;
  3682.  
  3683. procedure TWinControl.WMDrawItem(var Message: TWMDrawItem);
  3684. begin
  3685.   if not DoControlMsg(Message.DrawItemStruct^.CtlID, Message) then inherited;
  3686. end;
  3687.  
  3688. procedure TWinControl.WMMeasureItem(var Message: TWMMeasureItem);
  3689. begin
  3690.   if not DoControlMsg(Message.MeasureItemStruct^.CtlID, Message) then inherited;
  3691. end;
  3692.  
  3693. procedure TWinControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  3694. begin
  3695.   FillRect(Message.DC, ClientRect, FBrush.Handle);
  3696.   Message.Result := 1;
  3697. end;
  3698.  
  3699. procedure TWinControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  3700. var
  3701.   Framed, Resized: Boolean;
  3702. begin
  3703.   Framed := FCtl3D and (csFramed in ControlStyle) and (Parent <> nil) and
  3704.     (Message.WindowPos^.flags and SWP_NOREDRAW = 0);
  3705.   Resized := (Message.WindowPos^.flags and (SWP_NOMOVE or SWP_NOSIZE) <>
  3706.     (SWP_NOMOVE or SWP_NOSIZE)) and IsWindowVisible(FHandle);
  3707.   if Framed and Resized then
  3708.     InvalidateFrame;
  3709.   UpdateBounds;
  3710.   inherited;
  3711.   if Framed and (Resized or (Message.WindowPos^.flags and
  3712.     (SWP_SHOWWINDOW or SWP_HIDEWINDOW) <> 0)) then
  3713.     InvalidateFrame;
  3714. end;
  3715.  
  3716. procedure TWinControl.WMSize(var Message: TWMSize);
  3717. begin
  3718.   UpdateBounds;
  3719.   inherited;
  3720.   Realign;
  3721. end;
  3722.  
  3723. procedure TWinControl.WMMove(var Message: TWMMove);
  3724. begin
  3725.   inherited;
  3726.   UpdateBounds;
  3727. end;
  3728.  
  3729. procedure TWinControl.WMSetCursor(var Message: TWMSetCursor);
  3730. var
  3731.   Cursor: TCursor;
  3732.   Control: TControl;
  3733.   P: TPoint;
  3734. begin
  3735.   with Message do
  3736.     if CursorWnd = FHandle then
  3737.       case Smallint(HitTest) of
  3738.         HTCLIENT:
  3739.           begin
  3740.             if csDesigning in ComponentState then
  3741.               Cursor := crArrow
  3742.             else
  3743.             begin
  3744.               Cursor := Screen.Cursor;
  3745.               if Cursor = crDefault then
  3746.               begin
  3747.                 GetCursorPos(P);
  3748.                 Control := ControlAtPos(ScreenToClient(P), False);
  3749.                 if Control <> nil then Cursor := Control.FCursor;
  3750.                 if Cursor = crDefault then Cursor := FCursor;
  3751.               end;
  3752.             end;
  3753.             if Cursor <> crDefault then
  3754.             begin
  3755.               Windows.SetCursor(Screen.Cursors[Cursor]);
  3756.               Result := 1;
  3757.               Exit;
  3758.             end;
  3759.           end;
  3760.         HTERROR:
  3761.           if (MouseMsg = WM_LBUTTONDOWN) and (Application.Handle <> 0) and
  3762.             (GetForegroundWindow <> GetLastActivePopup(Application.Handle)) then
  3763.           begin
  3764.             Application.BringToFront;
  3765.             Exit;
  3766.           end;
  3767.       end;
  3768.   inherited;
  3769. end;
  3770.  
  3771. procedure TWinControl.WMSetFocus(var Message: TWMSetFocus);
  3772. begin
  3773.   inherited;
  3774.   SetIme;
  3775. end;
  3776.  
  3777. procedure TWinControl.WMKillFocus(var Message: TWMSetFocus);
  3778. begin
  3779.   inherited;
  3780.   ResetIme;
  3781. end;
  3782.  
  3783. procedure TWinControl.WMIMEStartComp(var Message: TMessage);
  3784. begin
  3785.   FInImeComposition := True;
  3786.   inherited;
  3787. end;
  3788.  
  3789. procedure TWinControl.WMIMEEndComp(var Message: TMessage);
  3790. begin
  3791.   FInImeComposition := False;
  3792.   inherited;
  3793. end;
  3794.  
  3795. function TWinControl.SetImeCompositionWindow(hWnd: HWND; Font: TFont;
  3796.   XPos, YPos: Integer): Boolean;
  3797. var
  3798.   H: HIMC;
  3799.   CForm: TCompositionForm;
  3800.   LFont: TLogFont;
  3801. begin
  3802.   Result := False;
  3803.   H := Imm32GetContext(hWnd);
  3804.   if H <> 0 then
  3805.   begin
  3806.     with CForm do
  3807.     begin
  3808.       dwStyle := CFS_POINT;
  3809.       ptCurrentPos.x := XPos;
  3810.       ptCurrentPos.y := YPos;
  3811.     end;
  3812.     Imm32SetCompositionWindow(H, @CForm);
  3813.     GetObject(Font.Handle, SizeOf(TLogFont), @LFont);
  3814.     Imm32SetCompositionFont(H, @LFont);
  3815.     Imm32ReleaseContext(hWnd, H);
  3816.     Result := True;
  3817.   end;
  3818. end;
  3819.  
  3820. function TWinControl.ResetImeComposition(Action: DWORD): Boolean;
  3821. var
  3822.   H: HIMC;
  3823. begin
  3824.   Result := False;
  3825.   if FInImeComposition then
  3826.   begin
  3827.     H := Imm32GetContext(Handle);
  3828.     if H <> 0 then
  3829.     begin
  3830.       Result := Imm32NotifyIME(H, NI_COMPOSITIONSTR, Action, 0);
  3831.       Imm32ReleaseContext(Handle, H);
  3832.     end;
  3833.   end;
  3834. end;
  3835.  
  3836. procedure TWinControl.SetIme;
  3837. var
  3838.   I: Integer;
  3839.   HandleToSet: HKL;
  3840. begin
  3841.   if not SysLocale.FarEast then Exit;
  3842.   if FImeName <> '' then
  3843.   begin
  3844.     if (AnsiCompareText(FImeName, Screen.DefaultIme) <> 0) and (Screen.Imes.Count <> 0) then
  3845.     begin
  3846.       HandleToSet := Screen.DefaultKbLayout;
  3847.       if FImeMode <> imDisable then
  3848.       begin
  3849.         I := Screen.Imes.IndexOf(FImeName);
  3850.         if I >= 0 then
  3851.           HandleToSet := HKL(Screen.Imes.Objects[I]);
  3852.       end;
  3853.       ActivateKeyboardLayout(HandleToSet, KLF_ACTIVATE);
  3854.     end;
  3855.   end;
  3856.   SetImeMode(Handle, FImeMode);
  3857. end;
  3858.  
  3859. procedure TWinControl.ResetIme;
  3860. begin
  3861.   if not SysLocale.FarEast then Exit;
  3862.   if FImeName <> '' then
  3863.   begin
  3864.     if AnsiCompareText(FImeName, Screen.DefaultIme) <> 0 then
  3865.       ActivateKeyboardLayout(Screen.DefaultKbLayout, KLF_ACTIVATE);
  3866.   end;
  3867.   if FImeMode = imDisable then Win32NLSEnableIME(Handle, TRUE);
  3868. end;
  3869.  
  3870. procedure TWinControl.DoEnter;
  3871. begin
  3872.   if Assigned(FOnEnter) then FOnEnter(Self);
  3873. end;
  3874.  
  3875. procedure TWinControl.DoExit;
  3876. begin
  3877.   if Assigned(FOnExit) then FOnExit(Self);
  3878. end;
  3879.  
  3880. procedure TWinControl.KeyDown(var Key: Word; Shift: TShiftState);
  3881. begin
  3882.   if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
  3883. end;
  3884.  
  3885. function TWinControl.DoKeyDown(var Message: TWMKey): Boolean;
  3886. var
  3887.   ShiftState: TShiftState;
  3888.   Form: TCustomForm;
  3889. begin
  3890.   Result := True;
  3891.   Form := GetParentForm(Self);
  3892.   if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
  3893.     TWinControl(Form).DoKeyDown(Message) then Exit;
  3894.   with Message do
  3895.   begin
  3896.     ShiftState := KeyDataToShiftState(KeyData);
  3897.     if not (csNoStdEvents in ControlStyle) then
  3898.     begin
  3899.       KeyDown(CharCode, ShiftState);
  3900.       if CharCode = 0 then Exit;
  3901.     end;
  3902.     if (CharCode = VK_APPS) and (ShiftState = []) then
  3903.       CheckMenuPopup(SmallPoint(0, 0));
  3904.   end;
  3905.   Result := False;
  3906. end;
  3907.  
  3908. procedure TWinControl.WMKeyDown(var Message: TWMKeyDown);
  3909. begin
  3910.   if not DoKeyDown(Message) then inherited;
  3911. end;
  3912.  
  3913. procedure TWinControl.WMSysKeyDown(var Message: TWMKeyDown);
  3914. begin
  3915.   if not DoKeyDown(Message) then inherited;
  3916. end;
  3917.  
  3918. procedure TWinControl.KeyUp(var Key: Word; Shift: TShiftState);
  3919. begin
  3920.   if Assigned(FOnKeyUp) then FOnKeyUp(Self, Key, Shift);
  3921. end;
  3922.  
  3923. function TWinControl.DoKeyUp(var Message: TWMKey): Boolean;
  3924. var
  3925.   Form: TCustomForm;
  3926. begin
  3927.   Result := True;
  3928.   Form := GetParentForm(Self);
  3929.   if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
  3930.     TWinControl(Form).DoKeyUp(Message) then Exit;
  3931.   if not (csNoStdEvents in ControlStyle) then
  3932.     with Message do
  3933.     begin
  3934.       KeyUp(CharCode, KeyDataToShiftState(KeyData));
  3935.       if CharCode = 0 then Exit;
  3936.     end;
  3937.   Result := False;
  3938. end;
  3939.  
  3940. procedure TWinControl.WMKeyUp(var Message: TWMKeyUp);
  3941. begin
  3942.   if not DoKeyUp(Message) then inherited;
  3943. end;
  3944.  
  3945. procedure TWinControl.WMSysKeyUp(var Message: TWMKeyUp);
  3946. begin
  3947.   if not DoKeyUp(Message) then inherited;
  3948. end;
  3949.  
  3950. procedure TWinControl.KeyPress(var Key: Char);
  3951. begin
  3952.   if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
  3953. end;
  3954.  
  3955. function TWinControl.DoKeyPress(var Message: TWMKey): Boolean;
  3956. var
  3957.   Form: TCustomForm;
  3958. begin
  3959.   Result := True;
  3960.   Form := GetParentForm(Self);
  3961.   if (Form <> nil) and (Form <> Self) and Form.KeyPreview and
  3962.     TWinControl(Form).DoKeyPress(Message) then Exit;
  3963.   if not (csNoStdEvents in ControlStyle) then
  3964.     with Message do
  3965.     begin
  3966.       KeyPress(Char(CharCode));
  3967.       if Char(CharCode) = #0 then Exit;
  3968.     end;
  3969.   Result := False;
  3970. end;
  3971.  
  3972. procedure TWinControl.WMChar(var Message: TWMChar);
  3973. begin
  3974.   if not DoKeyPress(Message) then inherited;
  3975. end;
  3976.  
  3977. procedure TWinControl.WMSysCommand(var Message: TWMSysCommand);
  3978. var
  3979.   Form: TCustomForm;
  3980. begin
  3981.   with Message do
  3982.     if (CmdType and $FFF0 = SC_KEYMENU) and (Key <> VK_SPACE) and
  3983.       (Key <> Word('-')) and not IsIconic(FHandle) and (GetCapture = 0) and
  3984.       (Application.MainForm <> Self) then
  3985.     begin
  3986.       Form := GetParentForm(Self);
  3987.       if (Form <> nil) and
  3988.         (Form.Perform(CM_APPSYSCOMMAND, 0, Longint(@Message)) <> 0) then
  3989.         Exit;
  3990.     end;
  3991.   inherited;
  3992. end;
  3993.  
  3994. procedure TWinControl.WMCharToItem(var Message: TWMCharToItem);
  3995. begin
  3996.   if not DoControlMsg(Message.ListBox, Message) then inherited;
  3997. end;
  3998.  
  3999. procedure TWinControl.WMParentNotify(var Message: TWMParentNotify);
  4000. begin
  4001.   with Message do
  4002.     if (Event <> WM_CREATE) and (Event <> WM_DESTROY) or
  4003.       not DoControlMsg(Message.ChildWnd, Message) then inherited;
  4004. end;
  4005.  
  4006. procedure TWinControl.WMVKeyToItem(var Message: TWMVKeyToItem);
  4007. begin
  4008.   if not DoControlMsg(Message.ListBox, Message) then inherited;
  4009. end;
  4010.  
  4011. procedure TWinControl.WMDestroy(var Message: TWMDestroy);
  4012. begin
  4013.   inherited;
  4014.   RemoveProp(FHandle, MakeIntAtom(ControlAtom));
  4015.   RemoveProp(FHandle, MakeIntAtom(WindowAtom));
  4016. end;
  4017.  
  4018. procedure TWinControl.WMNCDestroy(var Message: TWMNCDestroy);
  4019. begin
  4020.   inherited;
  4021.   FHandle := 0;
  4022.   FShowing := False;
  4023. end;
  4024.  
  4025. procedure TWinControl.WMNCHitTest(var Message: TWMNCHitTest);
  4026. begin
  4027.   with Message do
  4028.     if (csDesigning in ComponentState) and (FParent <> nil) then
  4029.       Result := HTCLIENT
  4030.     else
  4031.       inherited;
  4032. end;
  4033.  
  4034. function TWinControl.PaletteChanged(Foreground: Boolean): Boolean;
  4035. var
  4036.   I: Integer;
  4037. begin
  4038.   Result := inherited PaletteChanged(Foreground);
  4039.   if Visible then
  4040.     for I := ControlCount - 1 downto 0 do
  4041.     begin
  4042.       if Foreground and Result then Exit;
  4043.       Result := Controls[I].PaletteChanged(Foreground) or Result;
  4044.     end;
  4045. end;
  4046.  
  4047. procedure TWinControl.WMQueryNewPalette(var Message: TMessage);
  4048. begin
  4049.   Include(FControlState, csPalette);
  4050.   Message.Result := Longint(PaletteChanged(True));
  4051. end;
  4052.  
  4053. procedure TWinControl.WMPaletteChanged(var Message: TMessage);
  4054. begin
  4055.   Message.Result := Longint(PaletteChanged(False));
  4056. end;
  4057.  
  4058. procedure TWinControl.CMShowHintChanged(var Message: TMessage);
  4059. begin
  4060.   inherited;
  4061.   NotifyControls(CM_PARENTSHOWHINTCHANGED);
  4062. end;
  4063.  
  4064. procedure TWinControl.CMEnter(var Message: TCMEnter);
  4065. begin
  4066.   DoEnter;
  4067. end;
  4068.  
  4069. procedure TWinControl.CMExit(var Message: TCMExit);
  4070. begin
  4071.   DoExit;
  4072. end;
  4073.  
  4074. procedure TWinControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  4075. begin
  4076.   if not IsControlMouseMsg(Message) then inherited;
  4077. end;
  4078.  
  4079. procedure TWinControl.CMChanged(var Message: TMessage);
  4080. begin
  4081.   if FParent <> nil then FParent.WindowProc(Message);
  4082. end;
  4083.  
  4084. procedure TWinControl.CMChildKey(var Message: TMessage);
  4085. begin
  4086.   if FParent <> nil then FParent.WindowProc(Message);
  4087. end;
  4088.  
  4089. procedure TWinControl.CMDialogKey(var Message: TCMDialogKey);
  4090. begin
  4091.   Broadcast(Message);
  4092. end;
  4093.  
  4094. procedure TWinControl.CMDialogChar(var Message: TCMDialogChar);
  4095. begin
  4096.   Broadcast(Message);
  4097. end;
  4098.  
  4099. procedure TWinControl.CMFocusChanged(var Message: TCMFocusChanged);
  4100. begin
  4101.   Broadcast(Message);
  4102. end;
  4103.  
  4104. procedure TWinControl.CMVisibleChanged(var Message: TMessage);
  4105. begin
  4106.   if not FVisible and (Parent <> nil) then RemoveFocus(False);
  4107.   if not (csDesigning in ComponentState) or
  4108.     (csNoDesignVisible in ControlStyle) then UpdateControlState;
  4109. end;
  4110.  
  4111. procedure TWinControl.CMShowingChanged(var Message: TMessage);
  4112. const
  4113.   ShowFlags: array[Boolean] of Word = (
  4114.     SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW,
  4115.     SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW);
  4116. begin
  4117.   SetWindowPos(FHandle, 0, 0, 0, 0, 0, ShowFlags[FShowing]);
  4118. end;
  4119.  
  4120. procedure TWinControl.CMEnabledChanged(var Message: TMessage);
  4121. begin
  4122.   if not FEnabled and (Parent <> nil) then RemoveFocus(False);
  4123.   if HandleAllocated and not (csDesigning in ComponentState) then
  4124.     EnableWindow(FHandle, FEnabled);
  4125. end;
  4126.  
  4127. procedure TWinControl.CMColorChanged(var Message: TMessage);
  4128. begin
  4129.   inherited;
  4130.   FBrush.Color := FColor;
  4131.   NotifyControls(CM_PARENTCOLORCHANGED);
  4132. end;
  4133.  
  4134. procedure TWinControl.CMFontChanged(var Message: TMessage);
  4135. begin
  4136.   inherited;
  4137.   if HandleAllocated then Perform(WM_SETFONT, FFont.Handle, 0);
  4138.   NotifyControls(CM_PARENTFONTCHANGED);
  4139. end;
  4140.  
  4141. procedure TWinControl.CMCursorChanged(var Message: TMessage);
  4142. var
  4143.   P: TPoint;
  4144. begin
  4145.   if GetCapture = 0 then
  4146.   begin
  4147.     GetCursorPos(P);
  4148.     if FindDragTarget(P, False) = Self then
  4149.       Perform(WM_SETCURSOR, Handle, HTCLIENT);
  4150.   end;
  4151. end;
  4152.  
  4153. procedure TWinControl.CMCtl3DChanged(var Message: TMessage);
  4154. begin
  4155.   if (csFramed in ControlStyle) and (Parent <> nil) and HandleAllocated and
  4156.     IsWindowVisible(FHandle) then InvalidateFrame;
  4157.   NotifyControls(CM_PARENTCTL3DCHANGED);
  4158. end;
  4159.  
  4160. procedure TWinControl.CMParentCtl3DChanged(var Message: TMessage);
  4161. begin
  4162.   if FParentCtl3D then
  4163.   begin
  4164.     SetCtl3D(FParent.FCtl3D);
  4165.     FParentCtl3D := True;
  4166.   end;
  4167. end;
  4168.  
  4169. procedure TWinControl.CMSysColorChange(var Message: TMessage);
  4170. begin
  4171.   Broadcast(Message);
  4172. end;
  4173.  
  4174. procedure TWinControl.CMWinIniChange(var Message: TWMWinIniChange);
  4175. begin
  4176.   Broadcast(Message);
  4177. end;
  4178.  
  4179. procedure TWinControl.CMFontChange(var Message: TMessage);
  4180. begin
  4181.   Broadcast(Message);
  4182. end;
  4183.  
  4184. procedure TWinControl.CMTimeChange(var Message: TMessage);
  4185. begin
  4186.   Broadcast(Message);
  4187. end;
  4188.  
  4189. procedure TWinControl.CMDrag(var Message: TCMDrag);
  4190. begin
  4191.   with Message, DragRec^ do
  4192.     case DragMessage of
  4193.       dmDragEnter, dmDragLeave, dmDragMove, dmDragDrop:
  4194.         if Target <> nil then TControl(Target).DoDragMsg(Message);
  4195.       dmFindTarget:
  4196.         begin
  4197.           Result := Longint(ControlAtPos(ScreenToClient(Pos), False));
  4198.           if Result = 0 then Result := Longint(Self);
  4199.         end;
  4200.     end;
  4201. end;
  4202.  
  4203. procedure TWinControl.CMControlListChange(var Message: TMessage);
  4204. begin
  4205.   if FParent <> nil then FParent.WindowProc(Message);
  4206. end;
  4207.  
  4208. function TWinControl.IsMenuKey(var Message: TWMKey): Boolean;
  4209. var
  4210.   Control: TWinControl;
  4211.   Form: TCustomForm;
  4212.   LocalPopupMenu: TPopupMenu;
  4213. begin
  4214.   Result := True;
  4215.   if not (csDesigning in ComponentState) then
  4216.   begin
  4217.     Control := Self;
  4218.     while Control <> nil do
  4219.     begin
  4220.       LocalPopupMenu := Control.GetPopupMenu;
  4221.       if Assigned(LocalPopupMenu) and
  4222.         LocalPopupMenu.IsShortCut(Message) then Exit;
  4223.       Control := Control.Parent;
  4224.     end;
  4225.     Form := GetParentForm(Self);
  4226.     if (Form <> nil) and (Form.Menu <> nil) and
  4227.       Form.Menu.IsShortCut(Message) then Exit;
  4228.   end;
  4229.   with Message do
  4230.     if SendAppMessage(CM_APPKEYDOWN, CharCode, KeyData) <> 0 then Exit;
  4231.   Result := False;
  4232. end;
  4233.  
  4234. procedure TWinControl.CNKeyDown(var Message: TWMKeyDown);
  4235. var
  4236.   Mask: Integer;
  4237. begin
  4238.   with Message do
  4239.   begin
  4240.     Result := 1;
  4241.     if IsMenuKey(Message) then Exit;
  4242.     if not (csDesigning in ComponentState) then
  4243.     begin
  4244.       if Perform(CM_CHILDKEY, CharCode, Integer(Self)) <> 0 then Exit;
  4245.       Mask := 0;
  4246.       case CharCode of
  4247.         VK_TAB:
  4248.           Mask := DLGC_WANTTAB;
  4249.         VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:
  4250.           Mask := DLGC_WANTARROWS;
  4251.         VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
  4252.           Mask := DLGC_WANTALLKEYS;
  4253.       end;
  4254.       if (Mask <> 0) and
  4255.         (Perform(CM_WANTSPECIALKEY, CharCode, 0) = 0) and
  4256.         (Perform(WM_GETDLGCODE, 0, 0) and Mask = 0) and
  4257.         (GetParentForm(Self).Perform(CM_DIALOGKEY,
  4258.         CharCode, KeyData) <> 0) then Exit;
  4259.     end;
  4260.     Result := 0;
  4261.   end;
  4262. end;
  4263.  
  4264. procedure TWinControl.CNKeyUp(var Message: TWMKeyUp);
  4265. begin
  4266.   if not (csDesigning in ComponentState) then
  4267.     with Message do
  4268.       case CharCode of
  4269.         VK_TAB, VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN,
  4270.         VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
  4271.           Result := Perform(CM_WANTSPECIALKEY, CharCode, 0);
  4272.       end;
  4273. end;
  4274.  
  4275. procedure TWinControl.CNChar(var Message: TWMChar);
  4276. begin
  4277.   if not (csDesigning in ComponentState) then
  4278.     with Message do
  4279.     begin
  4280.       Result := 1;
  4281.       if (Perform(WM_GETDLGCODE, 0, 0) and DLGC_WANTCHARS = 0) and
  4282.         (GetParentForm(Self).Perform(CM_DIALOGCHAR,
  4283.         CharCode, KeyData) <> 0) then Exit;
  4284.       Result := 0;
  4285.     end;
  4286. end;
  4287.  
  4288. procedure TWinControl.CNSysKeyDown(var Message: TWMKeyDown);
  4289. begin
  4290.   with Message do
  4291.   begin
  4292.     Result := 1;
  4293.     if IsMenuKey(Message) then Exit;
  4294.     if not (csDesigning in ComponentState) then
  4295.     begin
  4296.       if Perform(CM_CHILDKEY, CharCode, Integer(Self)) <> 0 then Exit;
  4297.       if GetParentForm(Self).Perform(CM_DIALOGKEY,
  4298.         CharCode, KeyData) <> 0 then Exit;
  4299.     end;
  4300.     Result := 0;
  4301.   end;
  4302. end;
  4303.  
  4304. procedure TWinControl.CNSysChar(var Message: TWMChar);
  4305. begin
  4306.   if not (csDesigning in ComponentState) then
  4307.     with Message do
  4308.       if CharCode <> VK_SPACE then
  4309.         Result := GetParentForm(Self).Perform(CM_DIALOGCHAR,
  4310.           CharCode, KeyData);
  4311. end;
  4312.  
  4313. procedure TWinControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  4314. var
  4315.   WindowPlacement: TWindowPlacement;
  4316. begin
  4317.   if (ALeft <> FLeft) or (ATop <> FTop) or
  4318.     (AWidth <> FWidth) or (AHeight <> FHeight) then
  4319.   begin
  4320.     if HandleAllocated and not IsIconic(FHandle) then
  4321.       SetWindowPos(FHandle, 0, ALeft, ATop, AWidth, AHeight,
  4322.         SWP_NOZORDER + SWP_NOACTIVATE)
  4323.     else
  4324.     begin
  4325.       FLeft := ALeft;
  4326.       FTop := ATop;
  4327.       FWidth := AWidth;
  4328.       FHeight := AHeight;
  4329.       if HandleAllocated then
  4330.       begin
  4331.         WindowPlacement.Length := SizeOf(WindowPlacement);
  4332.         GetWindowPlacement(FHandle, @WindowPlacement);
  4333.         WindowPlacement.rcNormalPosition := BoundsRect;
  4334.         SetWindowPlacement(FHandle, @WindowPlacement);
  4335.       end;
  4336.     end;
  4337.     RequestAlign;
  4338.   end;
  4339. end;
  4340.  
  4341. procedure TWinControl.ScaleControls(M, D: Integer);
  4342. var
  4343.   I: Integer;
  4344. begin
  4345.   for I := 0 to ControlCount - 1 do Controls[I].ChangeScale(M, D);
  4346. end;
  4347.  
  4348. procedure TWinControl.ChangeScale(M, D: Integer);
  4349. begin
  4350.   DisableAlign;
  4351.   try
  4352.     ScaleControls(M, D);
  4353.     inherited ChangeScale(M, D);
  4354.   finally
  4355.     EnableAlign;
  4356.   end;
  4357. end;
  4358.  
  4359. procedure TWinControl.ScaleBy(M, D: Integer);
  4360. const
  4361.   SWP_HIDE = SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_HIDEWINDOW;
  4362.   SWP_SHOW = SWP_NOSIZE + SWP_NOMOVE + SWP_NOZORDER + SWP_NOACTIVATE + SWP_SHOWWINDOW;
  4363. var
  4364.   IsVisible: Boolean;
  4365.   R: TRect;
  4366. begin
  4367.   IsVisible := HandleAllocated and IsWindowVisible(Handle);
  4368.   if IsVisible then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDE);
  4369.   R := BoundsRect;
  4370.   ChangeScale(M, D);
  4371.   SetBounds(R.Left, R.Top, Width, Height);
  4372.   if IsVisible then SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_SHOW);
  4373. end;
  4374.  
  4375. procedure TWinControl.ScrollBy(DeltaX, DeltaY: Integer);
  4376. var
  4377.   IsVisible: Boolean;
  4378.   I: Integer;
  4379.   Control: TControl;
  4380. begin
  4381.   IsVisible := (FHandle <> 0) and IsWindowVisible(FHandle);
  4382.   if IsVisible then ScrollWindow(FHandle, DeltaX, DeltaY, nil, nil);
  4383.   for I := 0 to ControlCount - 1 do
  4384.   begin
  4385.     Control := Controls[I];
  4386.     if not (Control is TWinControl) or (TWinControl(Control).FHandle = 0) then
  4387.     begin
  4388.       Inc(Control.FLeft, DeltaX);
  4389.       Inc(Control.FTop, DeltaY);
  4390.     end else
  4391.       if not IsVisible then
  4392.         with TWinControl(Control) do
  4393.           SetWindowPos(FHandle, 0, FLeft + DeltaX, FTop + DeltaY,
  4394.             FWidth, FHeight, SWP_NOZORDER + SWP_NOACTIVATE);
  4395.   end;
  4396.   Realign;
  4397. end;
  4398.  
  4399. procedure TWinControl.ShowControl(AControl: TControl);
  4400. begin
  4401.   if Parent <> nil then Parent.ShowControl(Self);
  4402. end;
  4403.  
  4404. procedure TWinControl.SetZOrderPosition(Position: Integer);
  4405. var
  4406.   I, Count: Integer;
  4407.   Pos: HWND;
  4408. begin
  4409.   if FParent <> nil then
  4410.   begin
  4411.     if FParent.FControls <> nil then
  4412.       Dec(Position, FParent.FControls.Count);
  4413.     I := FParent.FWinControls.IndexOf(Self);
  4414.     if I >= 0 then
  4415.     begin
  4416.       Count := FParent.FWinControls.Count;
  4417.       if Position < 0 then Position := 0;
  4418.       if Position >= Count then Position := Count - 1;
  4419.       if Position <> I then
  4420.       begin
  4421.         FParent.FWinControls.Delete(I);
  4422.         FParent.FWinControls.Insert(Position, Self);
  4423.       end;
  4424.     end;
  4425.     if FHandle <> 0 then
  4426.     begin
  4427.       if Position = 0 then Pos := HWND_BOTTOM
  4428.       else if Position = FParent.FWinControls.Count - 1 then Pos := HWND_TOP
  4429.       else if Position > I then
  4430.         Pos := TWinControl(FParent.FWinControls[Position + 1]).Handle
  4431.       else if Position < I then
  4432.         Pos := TWinControl(FParent.FWinControls[Position]).Handle
  4433.       else Exit;
  4434.       SetWindowPos(FHandle, Pos, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE);
  4435.     end;
  4436.   end;
  4437. end;
  4438.  
  4439. procedure TWinControl.SetZOrder(TopMost: Boolean);
  4440. const
  4441.   WindowPos: array[Boolean] of Word = (HWND_BOTTOM, HWND_TOP);
  4442. var
  4443.   N, M: Integer;
  4444. begin
  4445.   if FParent <> nil then
  4446.   begin
  4447.     if TopMost then N := FParent.FWinControls.Count - 1 else N := 0;
  4448.     M := 0;
  4449.     if FParent.FControls <> nil then M := FParent.FControls.Count;
  4450.     SetZOrderPosition(M + N);
  4451.   end
  4452.   else if FHandle <> 0 then
  4453.     SetWindowPos(FHandle, WindowPos[TopMost], 0, 0, 0, 0,
  4454.       SWP_NOMOVE + SWP_NOSIZE);
  4455. end;
  4456.  
  4457. function TWinControl.GetDeviceContext(var WindowHandle: HWnd): HDC;
  4458. begin
  4459.   if csDesigning in ComponentState then
  4460.     Result := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS)
  4461.   else
  4462.     Result := GetDC(Handle);
  4463.   if Result = 0 then raise EOutOfResources.Create(SWindowDCError);
  4464.   WindowHandle := FHandle;
  4465. end;
  4466.  
  4467. function TWinControl.GetParentHandle: HWnd;
  4468. begin
  4469.   if Parent <> nil then
  4470.     Result := Parent.Handle
  4471.   else
  4472.     Result := ParentWindow;
  4473. end;
  4474.  
  4475. function TWinControl.GetTopParentHandle: HWnd;
  4476. var
  4477.   C: TWinControl;
  4478. begin
  4479.   C := Self;
  4480.   while C.Parent <> nil do
  4481.     C := C.Parent;
  4482.   Result := C.ParentWindow;
  4483.   if Result = 0 then Result := C.Handle;
  4484. end;
  4485.  
  4486. procedure TWinControl.Invalidate;
  4487. begin
  4488.   Perform(CM_INVALIDATE, 0, 0);
  4489. end;
  4490.  
  4491. procedure TWinControl.CMInvalidate(var Message: TMessage);
  4492. begin
  4493.   if HandleAllocated then
  4494.   begin
  4495.     if Parent <> nil then Parent.Perform(CM_INVALIDATE, 1, 0);
  4496.     if Message.WParam = 0 then
  4497.       InvalidateRect(FHandle, nil, not (csOpaque in ControlStyle));
  4498.   end;
  4499. end;
  4500.  
  4501. procedure TWinControl.Update;
  4502. begin
  4503.   if HandleAllocated then UpdateWindow(FHandle);
  4504. end;
  4505.  
  4506. procedure TWinControl.Repaint;
  4507. begin
  4508.   Invalidate;
  4509.   Update;
  4510. end;
  4511.  
  4512. procedure TWinControl.InvalidateFrame;
  4513. var
  4514.   R: TRect;
  4515. begin
  4516.   R := BoundsRect;
  4517.   InflateRect(R, 1, 1);
  4518.   InvalidateRect(Parent.FHandle, @R, True);
  4519. end;
  4520.  
  4521. function TWinControl.CanFocus: Boolean;
  4522. var
  4523.   Control: TWinControl;
  4524.   Form: TCustomForm;
  4525. begin
  4526.   Result := False;
  4527.   Form := GetParentForm(Self);
  4528.   if Form <> nil then
  4529.   begin
  4530.     Control := Self;
  4531.     while Control <> Form do
  4532.     begin
  4533.       if not (Control.FVisible and Control.FEnabled) then Exit;
  4534.       Control := Control.Parent;
  4535.     end;
  4536.     Result := True;
  4537.   end;
  4538. end;
  4539.  
  4540. procedure TWinControl.SetFocus;
  4541. var
  4542.   Parent: TCustomForm;
  4543. begin
  4544.   Parent := GetParentForm(Self);
  4545.   if Parent <> nil then
  4546.     Parent.FocusControl(Self)
  4547.   else if ParentWindow <> 0 then
  4548.     Windows.SetFocus(Handle)
  4549.   else
  4550.     ValidParentForm(Self);
  4551. end;
  4552.  
  4553. function TWinControl.Focused: Boolean;
  4554. begin
  4555.   Result := (FHandle <> 0) and (GetFocus = FHandle);
  4556. end;
  4557.  
  4558. procedure TWinControl.HandleNeeded;
  4559. begin
  4560.   if FHandle = 0 then
  4561.   begin
  4562.     if Parent <> nil then Parent.HandleNeeded;
  4563.     CreateHandle;
  4564.   end;
  4565. end;
  4566.  
  4567. function TWinControl.GetHandle: HWnd;
  4568. begin
  4569.   HandleNeeded;
  4570.   Result := FHandle;
  4571. end;
  4572.  
  4573. function TWinControl.GetClientOrigin: TPoint;
  4574. begin
  4575.   Result.X := 0;
  4576.   Result.Y := 0;
  4577.   Windows.ClientToScreen(Handle, Result);
  4578. end;
  4579.  
  4580. function TWinControl.GetClientRect: TRect;
  4581. begin
  4582.   Windows.GetClientRect(Handle, Result);
  4583. end;
  4584.  
  4585. procedure TWinControl.SetCtl3D(Value: Boolean);
  4586. begin
  4587.   if FCtl3D <> Value then
  4588.   begin
  4589.     FCtl3D := Value;
  4590.     FParentCtl3D := False;
  4591.     Perform(CM_CTL3DCHANGED, 0, 0);
  4592.   end;
  4593. end;
  4594.  
  4595. function TWinControl.IsCtl3DStored: Boolean;
  4596. begin
  4597.   Result := not ParentCtl3D;
  4598. end;
  4599.  
  4600. procedure TWinControl.SetParentCtl3D(Value: Boolean);
  4601. begin
  4602.   if FParentCtl3D <> Value then
  4603.   begin
  4604.     FParentCtl3D := Value;
  4605.     if FParent <> nil then Perform(CM_PARENTCTL3DCHANGED, 0, 0);
  4606.   end;
  4607. end;
  4608.  
  4609. function TWinControl.GetTabOrder: TTabOrder;
  4610. begin
  4611.   if FParent <> nil then
  4612.     Result := FParent.FTabList.IndexOf(Self)
  4613.   else
  4614.     Result := -1;
  4615. end;
  4616.  
  4617. procedure TWinControl.UpdateTabOrder(Value: TTabOrder);
  4618. var
  4619.   CurIndex, Count: Integer;
  4620. begin
  4621.   CurIndex := GetTabOrder;
  4622.   if CurIndex >= 0 then
  4623.   begin
  4624.     Count := FParent.FTabList.Count;
  4625.     if Value < 0 then Value := 0;
  4626.     if Value >= Count then Value := Count - 1;
  4627.     if Value <> CurIndex then
  4628.     begin
  4629.       FParent.FTabList.Delete(CurIndex);
  4630.       FParent.FTabList.Insert(Value, Self);
  4631.     end;
  4632.   end;
  4633. end;
  4634.  
  4635. procedure TWinControl.SetTabOrder(Value: TTabOrder);
  4636. begin
  4637.   if csReadingState in ControlState then
  4638.     FTabOrder := Value else
  4639.     UpdateTabOrder(Value);
  4640. end;
  4641.  
  4642. procedure TWinControl.SetTabStop(Value: Boolean);
  4643. var
  4644.   Style: Longint;
  4645. begin
  4646.   if FTabStop <> Value then
  4647.   begin
  4648.     FTabStop := Value;
  4649.     if HandleAllocated then
  4650.     begin
  4651.       Style := GetWindowLong(FHandle, GWL_STYLE) and not WS_TABSTOP;
  4652.       if Value then Style := Style or WS_TABSTOP;
  4653.       SetWindowLong(FHandle, GWL_STYLE, Style);
  4654.     end;
  4655.     Perform(CM_TABSTOPCHANGED, 0, 0);
  4656.   end;
  4657. end;
  4658.  
  4659. function TWinControl.HandleAllocated: Boolean;
  4660. begin
  4661.   Result := FHandle <> 0;
  4662. end;
  4663.  
  4664. procedure TWinControl.UpdateBounds;
  4665. var
  4666.   ParentHandle: HWnd;
  4667.   Rect: TRect;
  4668.   WindowPlacement: TWindowPlacement;
  4669. begin
  4670.   if IsIconic(FHandle) then
  4671.   begin
  4672.     WindowPlacement.Length := SizeOf(WindowPlacement);
  4673.     GetWindowPlacement(FHandle, @WindowPlacement);
  4674.     Rect := WindowPlacement.rcNormalPosition;
  4675.   end else
  4676.     GetWindowRect(FHandle, Rect);
  4677.   if GetWindowLong(FHandle, GWL_STYLE) and WS_CHILD <> 0 then
  4678.   begin
  4679.     ParentHandle := GetWindowLong(FHandle, GWL_HWNDPARENT);
  4680.     Windows.ScreenToClient(ParentHandle, Rect.TopLeft);
  4681.     Windows.ScreenToClient(ParentHandle, Rect.BottomRight);
  4682.   end;
  4683.   FLeft := Rect.Left;
  4684.   FTop := Rect.Top;
  4685.   FWidth := Rect.Right - Rect.Left;
  4686.   FHeight := Rect.Bottom - Rect.Top;
  4687. end;
  4688.  
  4689. procedure TWinControl.GetTabOrderList(List: TList);
  4690. var
  4691.   I: Integer;
  4692.   Control: TWinControl;
  4693. begin
  4694.   if FTabList <> nil then
  4695.     for I := 0 to FTabList.Count - 1 do
  4696.     begin
  4697.       Control := FTabList[I];
  4698.       List.Add(Control);
  4699.       Control.GetTabOrderList(List);
  4700.     end;
  4701. end;
  4702.  
  4703. function TWinControl.FindNextControl(CurControl: TWinControl;
  4704.   GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;
  4705. var
  4706.   I, StartIndex: Integer;
  4707.   List: TList;
  4708. begin
  4709.   Result := nil;
  4710.   List := TList.Create;
  4711.   try
  4712.     GetTabOrderList(List);
  4713.     if List.Count > 0 then
  4714.     begin
  4715.       StartIndex := List.IndexOf(CurControl);
  4716.       if StartIndex = -1 then
  4717.         if GoForward then StartIndex := List.Count - 1 else StartIndex := 0;
  4718.       I := StartIndex;
  4719.       repeat
  4720.         if GoForward then
  4721.         begin
  4722.           Inc(I);
  4723.           if I = List.Count then I := 0;
  4724.         end else
  4725.         begin
  4726.           if I = 0 then I := List.Count;
  4727.           Dec(I);
  4728.         end;
  4729.         CurControl := List[I];
  4730.         if CurControl.CanFocus and
  4731.           (not CheckTabStop or CurControl.TabStop) and
  4732.           (not CheckParent or (CurControl.Parent = Self)) then
  4733.           Result := CurControl;
  4734.       until (Result <> nil) or (I = StartIndex);
  4735.     end;
  4736.   finally
  4737.     List.Destroy;
  4738.   end;
  4739. end;
  4740.  
  4741. procedure TWinControl.SelectNext(CurControl: TWinControl;
  4742.   GoForward, CheckTabStop: Boolean);
  4743. begin
  4744.   CurControl := FindNextControl(CurControl, GoForward,
  4745.     CheckTabStop, not CheckTabStop);
  4746.   if CurControl <> nil then CurControl.SetFocus;
  4747. end;
  4748.  
  4749. procedure TWinControl.SelectFirst;
  4750. var
  4751.   Form: TCustomForm;
  4752.   Control: TWinControl;
  4753. begin
  4754.   Form := GetParentForm(Self);
  4755.   if Form <> nil then
  4756.   begin
  4757.     Control := FindNextControl(nil, True, True, False);
  4758.     if Control = nil then
  4759.       Control := FindNextControl(nil, True, False, False);
  4760.     if Control <> nil then Form.ActiveControl := Control;
  4761.   end;
  4762. end;
  4763.  
  4764. procedure TWinControl.GetChildren(Proc: TGetChildProc; Root: TComponent);
  4765. var
  4766.   I: Integer;
  4767.   Control: TControl;
  4768. begin
  4769.   for I := 0 to ControlCount - 1 do
  4770.   begin
  4771.     Control := Controls[I];
  4772.     if Control.Owner = Root then Proc(Control);
  4773.   end;
  4774. end;
  4775.  
  4776. procedure TWinControl.SetChildOrder(Child: TComponent; Order: Integer);
  4777. begin
  4778.   if Child is TWinControl then
  4779.     TWinControl(Child).SetZOrderPosition(Order)
  4780.   else if Child is TControl then
  4781.     TControl(Child).SetZOrderPosition(Order);
  4782. end;
  4783.  
  4784. { TGraphicControl }
  4785.  
  4786. constructor TGraphicControl.Create(AOwner: TComponent);
  4787. begin
  4788.   inherited Create(AOwner);
  4789.   FCanvas := TControlCanvas.Create;
  4790.   TControlCanvas(FCanvas).Control := Self;
  4791. end;
  4792.  
  4793. destructor TGraphicControl.Destroy;
  4794. begin
  4795.   FCanvas.Free;
  4796.   inherited Destroy;
  4797. end;
  4798.  
  4799. procedure TGraphicControl.WMPaint(var Message: TWMPaint);
  4800. begin
  4801.   if Message.DC <> 0 then
  4802.   begin
  4803.     Canvas.Lock;
  4804.     try
  4805.       Canvas.Handle := Message.DC;
  4806.       try
  4807.         Paint;
  4808.       finally
  4809.         Canvas.Handle := 0;
  4810.       end;
  4811.     finally
  4812.       Canvas.Unlock;
  4813.     end;
  4814.   end;
  4815. end;
  4816.  
  4817. procedure TGraphicControl.Paint;
  4818. begin
  4819. end;
  4820.  
  4821. { THintWindow }
  4822.  
  4823. constructor THintWindow.Create(AOwner: TComponent);
  4824. var
  4825.   NonClientMetrics: TNonClientMetrics;
  4826. begin
  4827.   inherited Create(AOwner);
  4828.   Color := $80FFFF;
  4829.  
  4830.   NonClientMetrics.cbSize := sizeof(NonClientMetrics);
  4831.   if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  4832.     Canvas.Font.Handle := CreateFontIndirect(NonClientMetrics.lfStatusFont)
  4833.   else
  4834.     Canvas.Font.Size := 8;
  4835.   Canvas.Brush.Style := bsClear;
  4836. end;
  4837.  
  4838. procedure THintWindow.CreateParams(var Params: TCreateParams);
  4839. begin
  4840.   inherited CreateParams(Params);
  4841.   with Params do
  4842.   begin
  4843.     Style := WS_POPUP or WS_BORDER or WS_DISABLED;
  4844.     WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  4845.     if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW;
  4846.   end;
  4847. end;
  4848.  
  4849. procedure THintWindow.WMNCPaint(var Message: TMessage);
  4850. var
  4851.   R: TRect;
  4852. begin
  4853.   Canvas.Handle := GetWindowDC(Handle);
  4854.   with Canvas do
  4855.   try
  4856.     R := Rect(0, 0, Width, Height);
  4857.     DrawEdge(Handle, R, BDR_RAISEDOUTER, BF_RECT);
  4858.   finally
  4859.     Canvas.Handle := 0;
  4860.   end;
  4861. end;
  4862.  
  4863. procedure THintWindow.Paint;
  4864. var
  4865.   R: TRect;
  4866. begin
  4867.   R := ClientRect;
  4868.   Inc(R.Left, 2);
  4869.   Inc(R.Top, 2);
  4870.   Canvas.Font.Color := clInfoText;
  4871.   DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_LEFT or DT_NOPREFIX or
  4872.     DT_WORDBREAK);
  4873. end;
  4874.  
  4875. function THintWindow.IsHintMsg(var Msg: TMsg): Boolean;
  4876. begin
  4877.   with Msg do
  4878.     Result := ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) or
  4879.       ((Message = CM_ACTIVATE) or (Message = CM_DEACTIVATE)) or
  4880.       (Message = CM_APPKEYDOWN) or (Message = CM_APPSYSCOMMAND) or
  4881.       (Message = WM_COMMAND) or ((Message > WM_MOUSEMOVE) and
  4882.       (Message <= WM_MOUSELAST)) or (Message = WM_NCMOUSEMOVE);
  4883. end;
  4884.  
  4885. procedure THintWindow.ReleaseHandle;
  4886. begin
  4887.   DestroyHandle;
  4888. end;
  4889.  
  4890. procedure THintWindow.CMTextChanged(var Message: TMessage);
  4891. begin
  4892.   inherited;
  4893.   Width := Canvas.TextWidth(Caption) + 6;
  4894.   Height := Canvas.TextHeight(Caption) + 4;
  4895. end;
  4896.  
  4897. procedure THintWindow.ActivateHint(Rect: TRect; const AHint: string);
  4898. begin
  4899.   Caption := AHint;
  4900.   Inc(Rect.Bottom, 4);
  4901.   BoundsRect := Rect;
  4902.  
  4903.   if Rect.Top + Height > Screen.Height then
  4904.     Rect.Top := Screen.Height - Height;
  4905.   if Rect.Left + Width > Screen.Width then
  4906.     Rect.Left := Screen.Width - Width;
  4907.   if Rect.Left < 0 then Rect.Left := 0;
  4908.   if Rect.Bottom < 0 then Rect.Bottom := 0;
  4909.  
  4910.   SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, 0,
  4911.     0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
  4912. end;
  4913.  
  4914. { TCustomControl }
  4915.  
  4916. constructor TCustomControl.Create(AOwner: TComponent);
  4917. begin
  4918.   inherited Create(AOwner);
  4919.   FCanvas := TControlCanvas.Create;
  4920.   TControlCanvas(FCanvas).Control := Self;
  4921. end;
  4922.  
  4923. destructor TCustomControl.Destroy;
  4924. begin
  4925.   FCanvas.Free;
  4926.   inherited Destroy;
  4927. end;
  4928.  
  4929. procedure TCustomControl.WMPaint(var Message: TWMPaint);
  4930. begin
  4931.   PaintHandler(Message);
  4932. end;
  4933.  
  4934. procedure TCustomControl.PaintWindow(DC: HDC);
  4935. begin
  4936.   FCanvas.Lock;
  4937.   try
  4938.     FCanvas.Handle := DC;
  4939.     try
  4940.       Paint;
  4941.     finally
  4942.       FCanvas.Handle := 0;
  4943.     end;
  4944.   finally
  4945.     FCanvas.Unlock;
  4946.   end;
  4947. end;
  4948.  
  4949. procedure TCustomControl.Paint;
  4950. begin
  4951. end;
  4952.  
  4953. { TCustomImageList }
  4954.  
  4955. function GetRGBColor(Value: TColor): Integer;
  4956. begin
  4957.   Result := ColorToRGB(Value);
  4958.   case Result of
  4959.     clNone: Result := CLR_NONE;
  4960.     clDefault: Result := CLR_DEFAULT;
  4961.   end;
  4962. end;
  4963.  
  4964. function GetColor(Value: Integer): TColor;
  4965. begin
  4966.   Result := TColor(Value);
  4967.   case Result of
  4968.     CLR_NONE: Result := clNone;
  4969.     CLR_DEFAULT: Result := clDefault;
  4970.   end;
  4971. end;
  4972.  
  4973. function ClientToWindow(Handle: HWND; X, Y: Integer): TPoint;
  4974. var
  4975.   Rect: TRect;
  4976.   Point: TPoint;
  4977. begin
  4978.   Point.X := X;
  4979.   Point.Y := Y;
  4980.   ClientToScreen(Handle, Point);
  4981.   GetWindowRect(Handle, Rect);
  4982.   Result.X := Point.X - Rect.Left;
  4983.   Result.Y := Point.Y - Rect.Top;
  4984. end;
  4985.  
  4986. constructor TCustomImageList.Create(AOwner: TComponent);
  4987. begin
  4988.   inherited Create(AOwner);
  4989.   FWidth := 16;
  4990.   FHeight := 16;
  4991.   Initialize;
  4992. end;
  4993.  
  4994. constructor TCustomImageList.CreateSize(AWidth, AHeight: Integer);
  4995. begin
  4996.   inherited Create(nil);
  4997.   FWidth := AWidth;
  4998.   FHeight := AHeight;
  4999.   Initialize;
  5000. end;
  5001.  
  5002. destructor TCustomImageList.Destroy;
  5003. begin
  5004.   while FClients.Count > 0 do
  5005.     UnRegisterChanges(TChangeLink(FClients.Last));
  5006.   FBitmap.Free;
  5007.   FreeHandle;
  5008.   FClients.Free;
  5009.   inherited Destroy;
  5010. end;
  5011.  
  5012. procedure TCustomImageList.Initialize;
  5013. const
  5014.   MaxSize = 32768;
  5015. begin
  5016.   FClients := TList.Create;
  5017.   if (Height < 1) or (Height > MaxSize) or (Width < 1) then
  5018.     raise EInvalidOperation.Create(SInvalidImageSize);
  5019.   AllocBy := 4;
  5020.   Masked := True;
  5021.   DrawingStyle := dsNormal;
  5022.   ImageType := itImage;
  5023.   FBkColor := clNone;
  5024.   FBlendColor := clNone;
  5025.   DragCursor := crNone;
  5026.   FBitmap := TBitmap.Create;
  5027.   InitBitmap;
  5028. end;
  5029.  
  5030. function TCustomImageList.HandleAllocated: Boolean;
  5031. begin
  5032.   Result := FHandle <> 0;
  5033. end;
  5034.  
  5035. procedure TCustomImageList.HandleNeeded;
  5036. begin
  5037.   if FHandle = 0 then CreateImageList;
  5038. end;
  5039.  
  5040. procedure TCustomImageList.InitBitmap;
  5041. var
  5042.   ScreenDC: HDC;
  5043. begin
  5044.   ScreenDC := GetDC(0);
  5045.   try
  5046.     with FBitmap do
  5047.     begin
  5048.       Handle := CreateCompatibleBitmap(ScreenDC, Self.Width, Self.Height);
  5049.       Canvas.Brush.Color := clBlack;
  5050.       Canvas.FillRect(Rect(0, 0, Width, Height));
  5051.     end;
  5052.   finally
  5053.     ReleaseDC(0, ScreenDC);
  5054.   end;
  5055. end;
  5056.  
  5057. procedure TCustomImageList.SetNewDimensions(Value: HImageList);
  5058. var
  5059.   AHeight, AWidth: Integer;
  5060. begin
  5061.   AWidth := Width;
  5062.   AHeight := Height;
  5063.   ImageList_GetIconSize(Value, AWidth, AHeight);
  5064.   FWidth := AWidth;
  5065.   FHeight := AHeight;
  5066.   InitBitmap;
  5067. end;
  5068.  
  5069. procedure TCustomImageList.SetWidth(Value: Integer);
  5070. begin
  5071.   if Value <> Width then
  5072.   begin
  5073.     FWidth := Value;
  5074.     if HandleAllocated then ImageList_SetIconSize(Handle, Width, Height);
  5075.     Clear;
  5076.     InitBitmap;
  5077.     Change;
  5078.   end;
  5079. end;
  5080.  
  5081. procedure TCustomImageList.SetHeight(Value: Integer);
  5082. begin
  5083.   if Value <> Height then
  5084.   begin
  5085.     FHeight := Value;
  5086.     if HandleAllocated then ImageList_SetIconSize(Handle, Width, Height);
  5087.     Clear;
  5088.     InitBitmap;
  5089.     Change;
  5090.   end;
  5091. end;
  5092.  
  5093. procedure TCustomImageList.SetHandle(Value: HImageList);
  5094. begin
  5095.   FreeHandle;
  5096.   if Value <> 0 then
  5097.   begin
  5098.     SetNewDimensions(Value);
  5099.     FHandle := Value;
  5100.     Change;
  5101.   end;
  5102. end;
  5103.  
  5104. function TCustomImageList.GetHandle: HImageList;
  5105. begin
  5106.   HandleNeeded;
  5107.   Result := FHandle;
  5108. end;
  5109.  
  5110. function TCustomImageList.GetImageHandle(Image: TBitmap): HBITMAP;
  5111. begin
  5112.   CheckImage(Image);
  5113.   if Image <> nil then
  5114.     Result := Image.Handle else
  5115.     Result := FBitmap.Handle;
  5116. end;
  5117.  
  5118. procedure TCustomImageList.FreeHandle;
  5119. begin
  5120.   if HandleAllocated and not ShareImages then
  5121.     ImageList_Destroy(Handle);
  5122.   FHandle := 0;
  5123.   Change;
  5124. end;
  5125.  
  5126. procedure TCustomImageList.CreateImageList;
  5127. const
  5128.   Mask: array[Boolean] of Longint = (0, ILC_MASK);
  5129. begin
  5130.   FHandle := ImageList_Create(Width, Height, ILC_COLOR or Mask[Masked],
  5131.     4, AllocBy);
  5132.   if FHandle = 0 then raise EInvalidOperation.Create(SInvalidImageList);
  5133.   if FBkColor <> clNone then BkColor := FBkColor;
  5134. end;
  5135.  
  5136. function TCustomImageList.GetImageBitmap: HBITMAP;
  5137. var
  5138.   Info: TImageInfo;
  5139. begin
  5140.   if (Count > 0) and ImageList_GetImageInfo(Handle, 0, Info) then
  5141.   begin
  5142.     Result := Info.hbmImage;
  5143.     DeleteObject(Info.hbmMask);
  5144.   end
  5145.   else Result := 0;
  5146. end;
  5147.  
  5148. function TCustomImageList.GetMaskBitmap: HBITMAP;
  5149. var
  5150.   Info: TImageInfo;
  5151. begin
  5152.   if (Count > 0) and ImageList_GetImageInfo(Handle, 0, Info) then
  5153.   begin
  5154.     Result := Info.hbmMask;
  5155.     DeleteObject(Info.hbmImage);
  5156.   end
  5157.   else Result := 0;
  5158. end;
  5159.  
  5160. function TCustomImageList.Add(Image, Mask: TBitmap): Integer;
  5161. begin
  5162.   Result := ImageList_Add(Handle, GetImageHandle(Image),
  5163.     GetImageHandle(Mask));
  5164. end;
  5165.  
  5166. function TCustomImageList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  5167. begin
  5168.   Result := ImageList_AddMasked(Handle, GetImageHandle(Image),
  5169.     ColorToRGB(MaskColor));
  5170.   Change;
  5171. end;
  5172.  
  5173. function TCustomImageList.AddIcon(Image: TIcon): Integer;
  5174. begin
  5175.   if Image = nil then
  5176.     Result := Add(nil, nil)
  5177.   else
  5178.   begin
  5179.     CheckImage(Image);
  5180.     Result := ImageList_AddIcon(Handle, Image.Handle);
  5181.   end;
  5182.   Change;
  5183. end;
  5184.  
  5185. procedure TCustomImageList.GetBitmap(Index: Integer; Image: TBitmap);
  5186. begin
  5187.   if (Image <> nil) and HandleAllocated then
  5188.     with Image do
  5189.     begin
  5190.       Height := FHeight;
  5191.       Width := FWidth;
  5192.       Draw(Canvas, 0, 0, Index);
  5193.     end;
  5194. end;
  5195.  
  5196. procedure TCustomImageList.GetIcon(Index: Integer; Image: TIcon);
  5197. const
  5198.   DrawingStyles: array[TDrawingStyle] of Longint = (ILD_FOCUS,
  5199.     ILD_SELECTED, ILD_NORMAL, ILD_TRANSPARENT);
  5200.   Images: array[TImageType] of Longint = (0, ILD_MASK);
  5201. begin
  5202.   if (Image <> nil) and HandleAllocated then
  5203.     Image.Handle := ImageList_GetIcon(Handle, Index,
  5204.       DrawingStyles[DrawingStyle] or Images[ImageType]);
  5205. end;
  5206.  
  5207. function TCustomImageList.GetCount: Integer;
  5208. begin
  5209.   if HandleAllocated then Result := ImageList_GetImageCount(Handle)
  5210.   else Result := 0;
  5211. end;
  5212.  
  5213. procedure TCustomImageList.Replace(Index: Integer; Image, Mask: TBitmap);
  5214. begin
  5215.   if HandleAllocated and not ImageList_Replace(Handle, Index,
  5216.     GetImageHandle(Image), GetImageHandle(Mask)) then
  5217.       raise EInvalidOperation.Create(SReplaceImage);
  5218.   Change;
  5219. end;
  5220.  
  5221. procedure TCustomImageList.ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor);
  5222. var
  5223.   TempIndex: Integer;
  5224.   Image, Mask: TBitmap;
  5225. begin
  5226.   if HandleAllocated then
  5227.   begin
  5228.     CheckImage(NewImage);
  5229.     TempIndex := AddMasked(NewImage, MaskColor);
  5230.     if TempIndex <> -1 then
  5231.     try
  5232.       Image := TBitmap.Create;
  5233.       Mask := TBitmap.Create;
  5234.       try
  5235.         with Image do
  5236.         begin
  5237.           Height := FHeight;
  5238.           Width := FWidth;
  5239.         end;
  5240.         with Mask do
  5241.         begin
  5242.           Height := FHeight;
  5243.           Width := FWidth;
  5244.         end;
  5245.         ImageList_Draw(Handle, TempIndex, Image.Canvas.Handle, 0, 0, ILD_NORMAL);
  5246.         ImageList_Draw(Handle, TempIndex, Mask.Canvas.Handle, 0, 0, ILD_NORMAL);
  5247.         if not ImageList_Replace(Handle, Index, Image.Handle, Mask.Handle) then
  5248.           raise EInvalidOperation.Create(SReplaceImage);
  5249.       finally
  5250.         Image.Free;
  5251.         Mask.Free;
  5252.       end;
  5253.     finally
  5254.       Delete(TempIndex);
  5255.     end
  5256.     else raise EInvalidOperation.Create(SReplaceImage);
  5257.   end;
  5258.   Change;
  5259. end;
  5260.  
  5261. procedure TCustomImageList.ReplaceIcon(Index: Integer; Image: TIcon);
  5262. begin
  5263.   if HandleAllocated then
  5264.     if Image = nil then Replace(Index, nil, nil)
  5265.     else begin
  5266.       CheckImage(Image);
  5267.       if ImageList_ReplaceIcon(Handle, Index, Image.Handle) = -1 then
  5268.         raise EInvalidOperation.Create(SReplaceImage);
  5269.     end;
  5270.   Change;
  5271. end;
  5272.  
  5273. procedure TCustomImageList.Delete(Index: Integer);
  5274. begin
  5275.   if Index >= Count then raise EInvalidOperation.Create(SImageIndexError);
  5276.   if HandleAllocated then ImageList_Remove(Handle, Index);
  5277.   Change;
  5278. end;
  5279.  
  5280. procedure TCustomImageList.Clear;
  5281. begin
  5282.   Delete(-1);
  5283.   Change;
  5284. end;
  5285.  
  5286. procedure TCustomImageList.SetBkColor(Value: TColor);
  5287. begin
  5288.   if HandleAllocated then ImageList_SetBkColor(Handle, GetRGBColor(Value))
  5289.   else FBkColor := Value;
  5290.   Change;
  5291. end;
  5292.  
  5293. function TCustomImageList.GetBkColor: TColor;
  5294. begin
  5295.   if HandleAllocated then Result := GetColor(ImageList_GetBkColor(Handle))
  5296.   else Result := FBkColor;
  5297. end;
  5298.  
  5299. procedure TCustomImageList.Draw(Canvas: TCanvas; X, Y, Index: Integer);
  5300. const
  5301.   DrawingStyles: array[TDrawingStyle] of Longint = (ILD_FOCUS,
  5302.     ILD_SELECTED, ILD_NORMAL, ILD_TRANSPARENT);
  5303.   Images: array[TImageType] of Longint = (0, ILD_MASK);
  5304. begin
  5305.   if HandleAllocated then
  5306.     ImageList_DrawEx(Handle, Index, Canvas.Handle, X, Y, 0, 0,
  5307.       GetRGBColor(BkColor), GetRGBColor(BlendColor),
  5308.       DrawingStyles[DrawingStyle] or Images[ImageType]);
  5309. end;
  5310.  
  5311. procedure TCustomImageList.DrawOverlay(Canvas: TCanvas; X, Y: Integer;
  5312.   ImageIndex: Integer; Overlay: TOverlay);
  5313. const
  5314.   Images: array[TImageType] of Longint = (0, ILD_MASK);
  5315. var
  5316.   Index: Integer;
  5317. begin
  5318.   if HandleAllocated then
  5319.   begin
  5320.     Index := IndexToOverlayMask(Overlay + 1);
  5321.     ImageList_Draw(Handle, ImageIndex, Canvas.Handle, X, Y,
  5322.       Images[ImageType] or (ILD_OVERLAYMASK and Index));
  5323.   end;
  5324. end;
  5325.  
  5326. function TCustomImageList.Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean;
  5327. begin
  5328.   if HandleAllocated then
  5329.     Result := ImageList_SetOverlayImage(Handle, ImageIndex, Overlay + 1)
  5330.   else Result := False;
  5331. end;
  5332.  
  5333. procedure TCustomImageList.CopyImages(Value: HImageList);
  5334. var
  5335.   I: Integer;
  5336.   Image, Mask: TBitmap;
  5337.   ARect: TRect;
  5338. begin
  5339.   ARect := Rect(0, 0, Width, Height);
  5340.   Image := TBitmap.Create;
  5341.   with Image do
  5342.   begin
  5343.     Height := FHeight;
  5344.     Width := FWidth;
  5345.   end;
  5346.   Mask := TBitmap.Create;
  5347.   with Mask do
  5348.   begin
  5349.     Height := FHeight;
  5350.     Width := FWidth;
  5351.   end;
  5352.   try
  5353.     for I := 0 to ImageList_GetImageCount(Value) - 1 do
  5354.     begin
  5355.       with Image.Canvas do
  5356.       begin
  5357.         FillRect(ARect);
  5358.         ImageList_Draw(Value, I, Handle, 0, 0, ILD_NORMAL);
  5359.       end;
  5360.       with Mask.Canvas do
  5361.       begin
  5362.         FillRect(ARect);
  5363.         ImageList_Draw(Value, I, Handle, 0, 0, ILD_MASK);
  5364.       end;
  5365.       Add(Image, Mask);
  5366.     end;
  5367.   finally
  5368.     Image.Free;
  5369.     Mask.Free;
  5370.   end;
  5371. end;
  5372.  
  5373. procedure TCustomImageList.GetImages(Index: Integer; Image, Mask: TBitmap);
  5374. var
  5375.   R: TRect;
  5376. begin
  5377.   R := Rect(0, 0, Width, Height);
  5378.   with Image.Canvas do
  5379.   begin
  5380.     Brush.Color := clWhite;
  5381.     FillRect(R);
  5382.     ImageList_Draw(Self.Handle, Index, Handle, 0, 0, ILD_NORMAL);
  5383.   end;
  5384.   with Mask.Canvas do
  5385.   begin
  5386.     Brush.Color := clWhite;
  5387.     FillRect(R);
  5388.     ImageList_Draw(Self.Handle, Index, Handle, 0, 0, ILD_MASK);
  5389.   end;
  5390. end;
  5391.  
  5392. procedure TCustomImageList.InsertImage(Index: Integer;
  5393.   Image, Mask: TBitmap; MaskColor: TColor);
  5394. var
  5395.   I: Integer;
  5396.   OldImage, OldMask: TBitmap;
  5397.   TempList: TCustomImageList;
  5398. begin
  5399.   OldImage := TBitmap.Create;
  5400.   with OldImage do
  5401.   begin
  5402.     Height := FHeight;
  5403.     Width := FWidth;
  5404.   end;
  5405.   OldMask := TBitmap.Create;
  5406.   with OldMask do
  5407.   begin
  5408.     Height := FHeight;
  5409.     Width := FWidth;
  5410.   end;
  5411.   TempList := TCustomImageList.CreateSize(5, 5);
  5412.   TempList.Assign(Self);
  5413.   Clear;
  5414.   if Index > TempList.Count then raise EInvalidOperation.Create(SImageIndexError);
  5415.   try
  5416.     for I := 0 to Index - 1 do
  5417.     begin
  5418.       TempList.GetImages(I, OldImage, OldMask);
  5419.       Add(OldImage, OldMask);
  5420.     end;
  5421.     if MaskColor <> -1 then
  5422.       AddMasked(Image, MaskColor) else
  5423.       Add(Image, Mask);
  5424.     for I := Index to TempList.Count - 1 do
  5425.     begin
  5426.       TempList.GetImages(I, OldImage, OldMask);
  5427.       Add(OldImage, OldMask);
  5428.     end;
  5429.   finally
  5430.     TempList.Free;
  5431.     OldImage.Free;
  5432.     OldMask.Free;
  5433.   end;
  5434. end;
  5435.  
  5436. procedure TCustomImageList.Insert(Index: Integer; Image, Mask: TBitmap);
  5437. begin
  5438.   InsertImage(Index, Image, Mask, -1);
  5439. end;
  5440.  
  5441. procedure TCustomImageList.InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor);
  5442. begin
  5443.   InsertImage(Index, Image, nil, MaskColor);
  5444. end;
  5445.  
  5446. procedure TCustomImageList.InsertIcon(Index: Integer; Image: TIcon);
  5447. var
  5448.   I: Integer;
  5449.   TempList: TCustomImageList;
  5450.   Icon: TIcon;
  5451. begin
  5452.   Icon := TIcon.Create;
  5453.   TempList := TCustomImageList.CreateSize(5, 5);
  5454.   TempList.Assign(Self);
  5455.   Clear;
  5456.   if Index > TempList.Count then raise EInvalidOperation.Create(SImageIndexError);
  5457.   try
  5458.     for I := 0 to Index - 1 do
  5459.     begin
  5460.       TempList.GetIcon(I, Icon);
  5461.       AddIcon(Icon);
  5462.     end;
  5463.     AddIcon(Image);
  5464.     for I := Index to TempList.Count - 1 do
  5465.     begin
  5466.       TempList.GetIcon(I, Icon);
  5467.       AddIcon(Icon);
  5468.     end;
  5469.   finally
  5470.     TempList.Free;
  5471.   end;
  5472. end;
  5473.  
  5474. procedure TCustomImageList.Move(CurIndex, NewIndex: Integer);
  5475. var
  5476.   Image, Mask: TBitmap;
  5477. begin
  5478.   if CurIndex <> NewIndex then
  5479.   begin
  5480.     Image := TBitmap.Create;
  5481.     with Image do
  5482.     begin
  5483.       Height := FHeight;
  5484.       Width := FWidth;
  5485.     end;
  5486.     Mask := TBitmap.Create;
  5487.     with Mask do
  5488.     begin
  5489.       Height := FHeight;
  5490.       Width := FWidth;
  5491.     end;
  5492.     try
  5493.       GetImages(CurIndex, Image, Mask);
  5494.       Delete(CurIndex);
  5495.       Insert(NewIndex, Image, Mask);
  5496.     finally
  5497.       Image.Free;
  5498.       Mask.Free;
  5499.     end;
  5500.   end;
  5501. end;
  5502.  
  5503. procedure TCustomImageList.AddImages(Value: TCustomImageList);
  5504. begin
  5505.   if Value <> nil then CopyImages(Value.Handle);
  5506. end;
  5507.  
  5508. procedure TCustomImageList.Assign(Source: TPersistent);
  5509. var
  5510.   ImageList: TCustomImageList;
  5511. begin
  5512.   if Source = nil then FreeHandle
  5513.   else if Source is TCustomImageList then
  5514.   begin
  5515.     Clear;
  5516.     ImageList := TCustomImageList(Source);
  5517.     Masked := ImageList.Masked;
  5518.     ImageType := ImageList.ImageType;
  5519.     DrawingStyle := ImageList.DrawingStyle;
  5520.     ShareImages := ImageList.ShareImages;
  5521.     SetNewDimensions(ImageList.Handle);
  5522.     if not HandleAllocated then HandleNeeded
  5523.     else ImageList_SetIconSize(Handle, Width, Height);
  5524.     BkColor := GetColor(ImageList_GetBkColor(ImageList.Handle));
  5525.     BlendColor := ImageList.BlendColor;
  5526.     AddImages(ImageList);
  5527.   end
  5528.   else inherited Assign(Source);
  5529. end;
  5530.  
  5531. procedure TCustomImageList.AssignTo(Dest: TPersistent);
  5532. var
  5533.   ImageList: TCustomImageList;
  5534. begin
  5535.   if Dest is TCustomImageList then
  5536.   begin
  5537.     ImageList := TCustomImageList(Dest);
  5538.     ImageList.Masked := Masked;
  5539.     ImageList.ImageType := ImageType;
  5540.     ImageList.DrawingStyle := DrawingStyle;
  5541.     ImageList.ShareImages := ShareImages;
  5542.     ImageList.BlendColor := BlendColor;
  5543.     with ImageList do
  5544.     begin
  5545.       Clear;
  5546.       SetNewDimensions(Self.Handle);
  5547.       if not HandleAllocated then HandleNeeded
  5548.       else ImageList_SetIconSize(Handle, Width, Height);
  5549.       BkColor := GetColor(ImageList_GetBkColor(Self.Handle));
  5550.       AddImages(Self);
  5551.     end;
  5552.   end
  5553.   else inherited AssignTo(Dest);
  5554. end;
  5555.  
  5556. procedure TCustomImageList.CheckImage(Image: TGraphic);
  5557. begin
  5558.   if Image = nil then Exit;
  5559.   with Image do
  5560.     if (Height < FHeight) or (Width < FWidth) then
  5561.       raise EInvalidOperation.Create(SInvalidImageSize);
  5562. end;
  5563.  
  5564. procedure TCustomImageList.CombineDragCursor;
  5565. var
  5566.   TempList: HImageList;
  5567.   Point: TPoint;
  5568. begin
  5569.   if DragCursor <> crNone then
  5570.   begin
  5571.     TempList := ImageList_Create(GetSystemMetrics(SM_CXCURSOR),
  5572.       GetSystemMetrics(SM_CYCURSOR), ILC_MASK, 1, 1);
  5573.     try
  5574.       ImageList_AddIcon(TempList, Screen.Cursors[DragCursor]);
  5575.       ImageList_AddIcon(TempList, Screen.Cursors[DragCursor]);
  5576.       ImageList_SetDragCursorImage(TempList, 0, 0, 0);
  5577.       ImageList_GetDragImage(nil, @Point);
  5578.       ImageList_SetDragCursorImage(TempList, 1, Point.X, Point.Y);
  5579.     finally
  5580.       ImageList_Destroy(TempList);
  5581.     end;
  5582.   end;
  5583. end;
  5584.  
  5585. procedure TCustomImageList.SetDragCursor(Value: TCursor);
  5586. begin
  5587.   if Value <> DragCursor then
  5588.   begin
  5589.     FDragCursor := Value;
  5590.     if Dragging then CombineDragCursor;
  5591.   end;
  5592. end;
  5593.  
  5594. function TCustomImageList.SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean;
  5595. begin
  5596.   if HandleAllocated then
  5597.   begin
  5598.     ImageList_BeginDrag(Handle, Index, HotSpotX, HotSpotY);
  5599.     Result := True;
  5600.     FDragging := Result;
  5601.   end
  5602.   else Result := False;
  5603. end;
  5604.  
  5605. function TCustomImageList.GetHotSpot: TPoint;
  5606. begin
  5607.   Result := Point(0, 0);
  5608.   if HandleAllocated and Dragging then
  5609.     ImageList_GetDragImage(nil, @Result);
  5610. end;
  5611.  
  5612. function TCustomImageList.BeginDrag(Window: HWND; X, Y: Integer): Boolean;
  5613. begin
  5614.   Result := False;
  5615.   if HandleAllocated then
  5616.   begin
  5617.     if not Dragging then SetDragImage(0, 0, 0);
  5618.     CombineDragCursor;
  5619.     Result := DragLock(Window, X, Y);
  5620.     if Result then ShowCursor(False);
  5621.   end;
  5622. end;
  5623.  
  5624. function TCustomImageList.DragLock(Window: HWND; XPos, YPos: Integer): Boolean;
  5625. begin
  5626.   Result := False;
  5627.   if HandleAllocated and (Window <> FDragHandle) then
  5628.   begin
  5629.     DragUnlock;
  5630.     FDragHandle := Window;
  5631.     with ClientToWindow(FDragHandle, XPos, YPos) do
  5632.       Result := ImageList_DragEnter(FDragHandle, X, Y);
  5633.   end;
  5634. end;
  5635.  
  5636. procedure TCustomImageList.DragUnlock;
  5637. begin
  5638.   if HandleAllocated and (FDragHandle <> 0) then
  5639.   begin
  5640.     ImageList_DragLeave(FDragHandle);
  5641.     FDragHandle := 0;
  5642.   end;
  5643. end;
  5644.  
  5645. function TCustomImageList.DragMove(X, Y: Integer): Boolean;
  5646. begin
  5647.   if HandleAllocated then
  5648.     with ClientToWindow(FDragHandle, X, Y) do
  5649.       Result := ImageList_DragMove(X, Y)
  5650.   else
  5651.     Result := False;
  5652. end;
  5653.  
  5654. procedure TCustomImageList.ShowDragImage;
  5655. begin
  5656.   if HandleAllocated then ImageList_DragShowNoLock(True);
  5657. end;
  5658.  
  5659. procedure TCustomImageList.HideDragImage;
  5660. begin
  5661.   if HandleAllocated then ImageList_DragShowNoLock(False);
  5662. end;
  5663.  
  5664. function TCustomImageList.EndDrag: Boolean;
  5665. begin
  5666.   if HandleAllocated and Dragging then
  5667.   begin
  5668.     DragUnlock;
  5669.     Result := ImageList_EndDrag;
  5670.     FDragging := False;
  5671.     DragCursor := crNone;
  5672.     ShowCursor(True);
  5673.   end
  5674.   else Result := False;
  5675. end;
  5676.  
  5677. function TCustomImageList.GetInstRes(Instance: THandle; ResType: TResType;
  5678.   Name: string; Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor):
  5679.   Boolean;
  5680. const
  5681.   ResMap: array [TResType] of Integer = (IMAGE_BITMAP, IMAGE_CURSOR, IMAGE_ICON);
  5682. var
  5683.   hImage: HImageList;
  5684.   Flags: Integer;
  5685. begin
  5686.   Flags := 0;
  5687.   if lrDefaultColor in LoadFlags then Flags := Flags or LR_DEFAULTCOLOR;
  5688.   if lrDefaultSize in LoadFlags then Flags := Flags or LR_DEFAULTSIZE;
  5689.   if lrFromFile in LoadFlags then Flags := Flags or LR_LOADFROMFILE;
  5690.   if lrMap3DColors in LoadFlags then Flags := Flags or LR_LOADMAP3DCOLORS;
  5691.   if lrTransparent in LoadFlags then Flags := Flags or LR_LOADTRANSPARENT;
  5692.   if lrMonoChrome in LoadFlags then Flags := Flags or LR_MONOCHROME;
  5693.   hImage := ImageList_LoadImage(Instance, PChar(Name), Width, AllocBy,
  5694.     MaskColor, ResMap[ResType], Flags);
  5695.   if hImage <> 0 then
  5696.   begin
  5697.     CopyImages(hImage);
  5698.     ImageList_Destroy(hImage);
  5699.     Result := True;
  5700.   end
  5701.   else Result := False;
  5702. end;
  5703.  
  5704. function TCustomImageList.GetResource(ResType: TResType; Name: string;
  5705.   Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean;
  5706. begin
  5707.   Result := GetInstRes(MainInstance, ResType, Name, Width, LoadFlags, MaskColor);
  5708. end;
  5709.  
  5710. function TCustomImageList.ResInstLoad(Instance: THandle; ResType: TResType;
  5711.   Name: string; MaskColor: TColor): Boolean;
  5712. begin
  5713.   Result := GetInstRes(Instance, ResType, Name, Width, [], MaskColor);
  5714. end;
  5715.  
  5716. function TCustomImageList.ResourceLoad(ResType: TResType; Name: string;
  5717.   MaskColor: TColor): Boolean;
  5718. begin
  5719.   Result := GetInstRes(MainInstance, ResType, Name, Width, [], MaskColor);
  5720. end;
  5721.  
  5722. function TCustomImageList.FileLoad(ResType: TResType; Name: string;
  5723.   MaskColor: TColor): Boolean;
  5724. begin
  5725.   Result := GetResource(ResType, Name, Width, [lrFromFile], MaskColor);
  5726. end;
  5727.  
  5728. procedure TCustomImageList.Change;
  5729. var
  5730.   I: Integer;
  5731. begin
  5732.   for I := 0 to FClients.Count - 1 do
  5733.     TChangeLink(FClients[I]).Change;
  5734.   if Assigned(FOnChange) then FOnChange(Self);
  5735. end;
  5736.  
  5737. procedure TCustomImageList.UnRegisterChanges(Value: TChangeLink);
  5738. var
  5739.   I: Integer;
  5740. begin
  5741.   for I := 0 to FClients.Count - 1 do
  5742.     if FClients[I] = Value then
  5743.     begin
  5744.       Value.Sender := nil;
  5745.       FClients.Delete(I);
  5746.       Break;
  5747.     end;
  5748. end;
  5749.  
  5750. procedure TCustomImageList.RegisterChanges(Value: TChangeLink);
  5751. begin
  5752.   Value.Sender := Self;
  5753.   FClients.Add(Value);
  5754. end;
  5755.  
  5756. function TCustomImageList.Equal(IL: TCustomImageList): Boolean;
  5757.  
  5758.   function StreamsEqual(S1, S2: TMemoryStream): Boolean;
  5759.   begin
  5760.     Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
  5761.   end;
  5762.  
  5763. var
  5764.   MyImage, OtherImage: TMemoryStream;
  5765. begin
  5766.   if (IL = nil) or (Count <> IL.Count) then
  5767.   begin
  5768.     Result := False;
  5769.     Exit;
  5770.   end;
  5771.   if (Count = 0) and (IL.Count = 0) then
  5772.   begin
  5773.     Result := True;
  5774.     Exit;
  5775.   end;
  5776.   MyImage := TMemoryStream.Create;
  5777.   try
  5778.     WriteData(MyImage);
  5779.     OtherImage := TMemoryStream.Create;
  5780.     try
  5781.       IL.WriteData(OtherImage);
  5782.       Result := StreamsEqual(MyImage, OtherImage);
  5783.     finally
  5784.       OtherImage.Free;
  5785.     end;
  5786.   finally
  5787.     MyImage.Free;
  5788.   end;
  5789. end;
  5790.  
  5791. procedure TCustomImageList.DefineProperties(Filer: TFiler);
  5792.  
  5793.   function DoWrite: Boolean;
  5794.   begin
  5795.     if Filer.Ancestor <> nil then
  5796.       Result := not (Filer.Ancestor is TCustomImageList) or
  5797.         not Equal(TCustomImageList(Filer.Ancestor))
  5798.     else
  5799.       Result := Count > 0;
  5800.   end;
  5801.  
  5802. begin
  5803.   inherited DefineProperties(Filer);
  5804.   Filer.DefineBinaryProperty('Bitmap', ReadData, WriteData, DoWrite);
  5805. end;
  5806.  
  5807. procedure TCustomImageList.ReadD2Stream(Stream: TStream);
  5808. var
  5809.   FullImage, Image, FullMask, Mask: TBitmap;
  5810.   I, J, Size, Pos, Count: Integer;
  5811.   SrcRect: TRect;
  5812. begin
  5813.   Stream.ReadBuffer(Size, SizeOf(Size));
  5814.   Stream.ReadBuffer(Count, SizeOf(Count));
  5815.   FullImage := TBitmap.Create;
  5816.   try
  5817.     Pos := Stream.Position;
  5818.     FullImage.LoadFromStream(Stream);
  5819.     Stream.Position := Pos + Size;
  5820.     FullMask := TBitmap.Create;
  5821.     try
  5822.       FullMask.LoadFromStream(Stream);
  5823.       Image := TBitmap.Create;
  5824.       Image.Width := Width;
  5825.       Image.Height := Height;
  5826.       Mask := TBitmap.Create;
  5827.       Mask.Monochrome := True;
  5828.       Mask.Width := Width;
  5829.       Mask.Height := Height;
  5830.       SrcRect := Rect(0, 0, Width, Height);
  5831.       try
  5832.         for J := 0 to (FullImage.Height div Height) - 1 do
  5833.         begin
  5834.           if Count = 0 then Break;
  5835.           for I := 0 to (FullImage.Width div Width) - 1 do
  5836.           begin
  5837.             if Count = 0 then Break;
  5838.             Image.Canvas.CopyRect(SrcRect, FullImage.Canvas,
  5839.               Bounds(I * Width, J * Height, Width, Height));
  5840.             Mask.Canvas.CopyRect(SrcRect, FullMask.Canvas,
  5841.               Bounds(I * Width, J * Height, Width, Height));
  5842.             Add(Image, Mask);
  5843.             Dec(Count);
  5844.           end;
  5845.         end;
  5846.       finally
  5847.         Image.Free;
  5848.         Mask.Free;
  5849.       end;
  5850.     finally
  5851.       FullMask.Free;
  5852.     end;
  5853.   finally
  5854.     FullImage.Free;
  5855.   end;
  5856. end;
  5857.  
  5858. procedure TCustomImageList.ReadD3Stream(Stream: TStream);
  5859. var
  5860.   SA: TStreamAdapter;
  5861. begin
  5862.   SA := TStreamAdapter.Create(Stream);
  5863.   try
  5864.     Handle := ImageList_Read(SA);
  5865.     if Handle = 0 then
  5866.       raise EReadError.Create(SImageReadFail);
  5867.   finally
  5868.     SA.Free;
  5869.   end;
  5870. end;
  5871.  
  5872. procedure TCustomImageList.ReadData(Stream: TStream);
  5873. var
  5874.   CheckInt1, CheckInt2: Integer;
  5875.   CheckByte1, CheckByte2: Byte;
  5876.   StreamPos: Integer;
  5877. begin
  5878.   StreamPos := Stream.Position;              // check stream signature to
  5879.   Stream.Read(CheckInt1, SizeOf(CheckInt1)); // determine a Delphi 2 or Delphi
  5880.   Stream.Read(CheckInt2, SizeOf(CheckInt2)); // 3 imagelist stream.  Delphi 2
  5881.   CheckByte1 := Lo(LoWord(CheckInt1));       // streams can be read, but only
  5882.   CheckByte2 := Hi(LoWord(CheckInt1));       // Delphi 3 streams will be written
  5883.   Stream.Position := StreamPos;
  5884.   if (CheckInt1 <> CheckInt2) and (CheckByte1 = $49) and (CheckByte2 = $4C) then
  5885.     ReadD3Stream(Stream)
  5886.   else
  5887.     ReadD2Stream(Stream);
  5888. end;
  5889.  
  5890. procedure TCustomImageList.WriteData(Stream: TStream);
  5891. var
  5892.   SA: TStreamAdapter;
  5893. begin
  5894.   SA := TStreamAdapter.Create(Stream);
  5895.   try
  5896.     if not ImageList_Write(Handle, SA) then
  5897.       raise EWriteError.Create(SImageWriteFail);
  5898.   finally
  5899.     SA.Free;
  5900.   end;
  5901. end;
  5902.  
  5903. { TChangeLink }
  5904.  
  5905. destructor TChangeLink.Destroy;
  5906. begin
  5907.   if Sender <> nil then Sender.UnRegisterChanges(Self);
  5908.   inherited Destroy;
  5909. end;
  5910.  
  5911. procedure TChangeLink.Change;
  5912. begin
  5913.   if Assigned(OnChange) then OnChange(Sender);
  5914. end;
  5915.  
  5916. { Input Method Editor (IME) support code }
  5917.  
  5918. var
  5919.   IMM32DLL: THandle = 0;
  5920.   _WINNLSEnableIME: function(hwnd: HWnd; bool: Boolean): Boolean stdcall;
  5921.   _ImmGetContext: function(hWnd: HWND): HIMC stdcall;
  5922.   _ImmReleaseContext: function(hWnd: HWND; hImc: HIMC): Boolean stdcall;
  5923.   _ImmGetConversionStatus: function(hImc: HIMC; var Conversion, Sentence: DWORD): Boolean stdcall;
  5924.   _ImmSetConversionStatus: function(hImc: HIMC; Conversion, Sentence: DWORD): Boolean stdcall;
  5925.   _ImmSetOpenStatus: function(hImc: HIMC; fOpen: Boolean): Boolean stdcall;
  5926.   _ImmSetCompositionWindow: function(hImc: HIMC; lpCompForm: PCOMPOSITIONFORM): Boolean stdcall;
  5927.   _ImmSetCompositionFont: function(hImc: HIMC; lpLogfont: PLOGFONTA): Boolean stdcall;
  5928.   _ImmGetCompositionString: function(hImc: HIMC; dWord1: DWORD; lpBuf: pointer; dwBufLen: DWORD): Longint stdcall;
  5929.   _ImmIsIME: function(hKl: HKL): Boolean stdcall;
  5930.   _ImmNotifyIME: function(hImc: HIMC; dwAction, dwIndex, dwValue: DWORD): Boolean stdcall;
  5931.  
  5932. procedure InitIMM32;
  5933. var
  5934.   UserHandle: THandle;
  5935.   OldError: Longint;
  5936. begin
  5937.   if not Syslocale.FarEast then Exit;
  5938.   OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  5939.   try
  5940.     if not Assigned(_WINNLSEnableIME) then
  5941.     begin
  5942.       UserHandle := GetModuleHandle('USER32');
  5943.       @_WINNLSEnableIME := GetProcAddress(UserHandle, 'WINNLSEnableIME');
  5944.     end;
  5945.  
  5946.     if IMM32DLL = 0 then
  5947.     begin
  5948.       IMM32DLL := LoadLibrary('IMM32.DLL');
  5949.       if (IMM32DLL >= 0) and (IMM32DLL < 32) then IMM32DLL := 0;
  5950.       if IMM32DLL <> 0 then
  5951.       begin
  5952.         @_ImmGetContext := GetProcAddress(IMM32DLL, 'ImmGetContext');
  5953.         @_ImmReleaseContext := GetProcAddress(IMM32DLL, 'ImmReleaseContext');
  5954.         @_ImmGetConversionStatus := GetProcAddress(IMM32DLL, 'ImmGetConversionStatus');
  5955.         @_ImmSetConversionStatus := GetProcAddress(IMM32DLL, 'ImmSetConversionStatus');
  5956.         @_ImmSetOpenStatus := GetProcAddress(IMM32DLL, 'ImmSetOpenStatus');
  5957.         @_ImmSetCompositionWindow := GetProcAddress(IMM32DLL, 'ImmSetCompositionWindow');
  5958.         @_ImmSetCompositionFont := GetProcAddress(IMM32DLL, 'ImmSetCompositionFontA');
  5959.         @_ImmGetCompositionString := GetProcAddress(IMM32DLL, 'ImmGetCompositionStringA');
  5960.         @_ImmIsIME := GetProcAddress(IMM32DLL, 'ImmIsIME');
  5961.         @_ImmNotifyIME := GetProcAddress(IMM32DLL, 'ImmNotifyIME');
  5962.       end;
  5963.     end;
  5964.   finally
  5965.     SetErrorMode(OldError);
  5966.   end;
  5967. end;
  5968.  
  5969. function Win32NLSEnableIME(Handle: HWnd; Enable: Boolean): Boolean;
  5970. begin
  5971.   if Assigned(_WINNLSEnableIME) then
  5972.     Result := _WINNLSEnableIME(Handle, Enable)
  5973.   else
  5974.     Result := False;
  5975. end;
  5976.  
  5977. procedure SetImeMode(Handle: HWnd; Mode: TImeMode);
  5978. const
  5979.   ModeMap: array [imSAlpha..imHanguel] of Byte =  // flags in use are all < 255
  5980.     ( { imSAlpha: } IME_CMODE_ALPHANUMERIC,
  5981.       { imAlpha:  } IME_CMODE_ALPHANUMERIC or IME_CMODE_FULLSHAPE,
  5982.       { imHira:   } IME_CMODE_NATIVE or IME_CMODE_FULLSHAPE,
  5983.       { imSKata:  } IME_CMODE_NATIVE or IME_CMODE_KATAKANA,
  5984.       { imKata:   } IME_CMODE_NATIVE or IME_CMODE_KATAKANA or IME_CMODE_FULLSHAPE,
  5985.       { imChinese:} IME_CMODE_NATIVE or IME_CMODE_FULLSHAPE,
  5986.       { imSHanguel} IME_CMODE_NATIVE,
  5987.       { imHanguel } IME_CMODE_NATIVE or IME_CMODE_FULLSHAPE );
  5988. var
  5989.   IMC: HIMC;
  5990.   Conv, Sent: DWORD;
  5991. begin
  5992.   if (not SysLocale.FarEast) or (Mode = imDontCare) then Exit;
  5993.  
  5994.   if Mode = imDisable then
  5995.   begin
  5996.     Win32NLSEnableIME(Handle, FALSE);
  5997.     Exit;
  5998.   end;
  5999.  
  6000.   Win32NLSEnableIME(Handle, TRUE);
  6001.  
  6002.   if IMM32DLL = 0 then Exit;
  6003.  
  6004.   IMC := _ImmGetContext(Handle);
  6005.   if IMC = 0 then Exit;
  6006.  
  6007.   _ImmGetConversionStatus(IMC, Conv, Sent);
  6008.  
  6009.   case Mode of
  6010.     imClose: _ImmSetOpenStatus(IMC, FALSE);
  6011.     imOpen : _ImmSetOpenStatus(IMC, TRUE);
  6012.   else
  6013.     _ImmSetOpenStatus(IMC, TRUE);
  6014.     _ImmGetConversionStatus(IMC, Conv, Sent);
  6015.     Conv := Conv and
  6016.      (not(IME_CMODE_LANGUAGE or IME_CMODE_FULLSHAPE)) or ModeMap[Mode];
  6017.   end;
  6018.   _ImmSetConversionStatus(IMC, Conv, Sent);
  6019.   _ImmReleaseContext(Handle, IMC);
  6020. end;
  6021.  
  6022. function Imm32GetContext(hWnd: HWND): HIMC;
  6023. begin
  6024.   if IMM32DLL <> 0 then
  6025.     Result := _ImmGetContext(hWnd)
  6026.   else
  6027.     Result := 0;
  6028. end;
  6029.  
  6030. function Imm32ReleaseContext(hWnd: HWND; hImc: HIMC): Boolean;
  6031. begin
  6032.   if IMM32DLL <> 0 then
  6033.     Result := _ImmReleaseContext(hWnd, hImc)
  6034.   else
  6035.     Result := False;
  6036. end;
  6037.  
  6038. function Imm32GetConversionStatus(hImc: HIMC; var Conversion, Sentence: DWORD): Boolean;
  6039. begin
  6040.   if IMM32DLL <> 0 then
  6041.     Result := _ImmGetConversionStatus(hImc, Conversion, Sentence)
  6042.   else
  6043.     Result := False;
  6044. end;
  6045.  
  6046. function Imm32SetConversionStatus(hImc: HIMC; Conversion, Sentence: DWORD): Boolean;
  6047. begin
  6048.   if IMM32DLL <> 0 then
  6049.     Result := _ImmSetConversionStatus(hImc, Conversion, Sentence)
  6050.   else
  6051.     Result := False;
  6052. end;
  6053.  
  6054. function Imm32SetOpenStatus(hImc: HIMC; fOpen: Boolean): Boolean;
  6055. begin
  6056.   if IMM32DLL <> 0 then
  6057.     Result := _ImmSetOpenStatus(hImc, fOpen)
  6058.   else
  6059.     Result := False;
  6060. end;
  6061.  
  6062. function Imm32SetCompositionWindow(hImc: HIMC; lpCompForm: PCOMPOSITIONFORM): Boolean;
  6063. begin
  6064.   if IMM32DLL <> 0 then
  6065.     Result := _ImmSetCompositionWindow(hImc, lpCompForm)
  6066.   else
  6067.     Result := False;
  6068. end;
  6069.  
  6070. function Imm32SetCompositionFont(hImc: HIMC; lpLogfont: PLOGFONTA): Boolean;
  6071. begin
  6072.   if IMM32DLL <> 0 then
  6073.     Result := _ImmSetCompositionFont(hImc, lpLogFont)
  6074.   else
  6075.     Result := False;
  6076. end;
  6077.  
  6078. function Imm32GetCompositionString(hImc: HIMC; dWord1: DWORD; lpBuf: pointer; dwBufLen: DWORD): Longint;
  6079. begin
  6080.   if IMM32DLL <> 0 then
  6081.     Result := _ImmGetCompositionString(hImc, dWord1, lpBuf, dwBufLen)
  6082.   else
  6083.     Result := 0;
  6084. end;
  6085.  
  6086. function Imm32IsIME(hKl: HKL): Boolean;
  6087. begin
  6088.   if IMM32DLL <> 0 then
  6089.     Result := _ImmIsIME(hKl)
  6090.   else
  6091.     Result := False;
  6092. end;
  6093.  
  6094. function Imm32NotifyIME(hImc: HIMC; dwAction, dwIndex, dwValue: DWORD): Boolean;
  6095. begin
  6096.   if IMM32DLL <> 0 then
  6097.     Result := _ImmNotifyIME(hImc, dwAction, dwIndex, dwValue)
  6098.   else
  6099.     Result := False;
  6100. end;
  6101.  
  6102.  
  6103. { Initialization and cleanup }
  6104.  
  6105. procedure DoneControls; far;
  6106. begin
  6107.   Application.Free;
  6108.   Screen.Free;
  6109.   CanvasList.Free;
  6110.   GlobalDeleteAtom(ControlAtom);
  6111.   GlobalDeleteAtom(WindowAtom);
  6112.   if IMM32DLL <> 0 then FreeLibrary(IMM32DLL);
  6113. end;
  6114.  
  6115. procedure InitControls;
  6116. var
  6117.   AtomText: array[0..31] of Char;
  6118. begin
  6119.   WindowAtom := GlobalAddAtom(StrFmt(AtomText, 'Delphi%.8X',
  6120.     [GetCurrentProcessID]));
  6121.   ControlAtom := GlobalAddAtom(
  6122.     StrFmt(AtomText, 'ControlOfs%.8X%.8X', [HInstance, GetCurrentThreadID]));
  6123.   CanvasList := TList.Create;
  6124.   CanvasList.Capacity := 4;
  6125.   InitIMM32;
  6126.   Screen := TScreen.Create(nil);
  6127.   Application := TApplication.Create(nil);
  6128.   InitCtl3D;
  6129.   Application.ShowHint := True;
  6130.   RegisterIntegerConsts(TypeInfo(TCursor), IdentToCursor, CursorToIdent);
  6131. end;
  6132.  
  6133. initialization
  6134.   NewStyleControls := Lo(GetVersion) >= 4;
  6135.   InitControls;
  6136. finalization
  6137.   DoneControls;
  6138. end.
  6139.